+++ /dev/null
-module Constants where
-
-import qualified Language.VHDL.AST as AST
-
---------------
--- Identifiers
---------------
-
--- | reset and clock signal identifiers in String form
-resetStr, clockStr :: String
-resetStr = "resetn"
-clockStr = "clock"
-
--- | reset and clock signal identifiers in basic AST.VHDLId form
-resetId, clockId :: AST.VHDLId
-resetId = AST.unsafeVHDLBasicId resetStr
-clockId = AST.unsafeVHDLBasicId clockStr
-
-
--- | \"types\" identifier
-typesId :: AST.VHDLId
-typesId = AST.unsafeVHDLBasicId "types"
-
--- | work identifier
-workId :: AST.VHDLId
-workId = AST.unsafeVHDLBasicId "work"
-
--- | std identifier
-stdId :: AST.VHDLId
-stdId = AST.unsafeVHDLBasicId "std"
-
-
--- | textio identifier
-textioId :: AST.VHDLId
-textioId = AST.unsafeVHDLBasicId "textio"
-
--- | range attribute identifier
-rangeId :: AST.VHDLId
-rangeId = AST.unsafeVHDLBasicId "range"
-
-
--- | high attribute identifier
-highId :: AST.VHDLId
-highId = AST.unsafeVHDLBasicId "high"
-
--- | range attribute identifier
-imageId :: AST.VHDLId
-imageId = AST.unsafeVHDLBasicId "image"
-
--- | event attribute identifie
-eventId :: AST.VHDLId
-eventId = AST.unsafeVHDLBasicId "event"
-
-
--- | default function identifier
-defaultId :: AST.VHDLId
-defaultId = AST.unsafeVHDLBasicId "default"
-
--- FSVec function identifiers
-
--- | ex (operator ! in original Haskell source) function identifier
-exId :: String
-exId = "!"
-
--- | sel (function select in original Haskell source) function identifier
-selId :: String
-selId = "select"
-
-
--- | ltplus (function (<+) in original Haskell source) function identifier
-ltplusId :: String
-ltplusId = "<+"
-
-
--- | plusplus (function (++) in original Haskell source) function identifier
-plusplusId :: String
-plusplusId = "++"
-
-
--- | empty function identifier
-emptyId :: String
-emptyId = "empty"
-
--- | plusgt (function (+>) in original Haskell source) function identifier
-plusgtId :: String
-plusgtId = "+>"
-
--- | singleton function identifier
-singletonId :: String
-singletonId = "singleton"
-
--- | length function identifier
-lengthId :: String
-lengthId = "length"
-
-
--- | isnull (function null in original Haskell source) function identifier
-nullId :: String
-nullId = "null"
-
-
--- | replace function identifier
-replaceId :: String
-replaceId = "replace"
-
-
--- | head function identifier
-headId :: String
-headId = "head"
-
-
--- | last function identifier
-lastId :: String
-lastId = "last"
-
-
--- | init function identifier
-initId :: String
-initId = "init"
-
-
--- | tail function identifier
-tailId :: String
-tailId = "tail"
-
-
--- | take function identifier
-takeId :: String
-takeId = "take"
-
-
--- | drop function identifier
-dropId :: String
-dropId = "drop"
-
--- | shiftl function identifier
-shiftlId :: String
-shiftlId = "shiftl"
-
--- | shiftr function identifier
-shiftrId :: String
-shiftrId = "shiftr"
-
--- | rotl function identifier
-rotlId :: String
-rotlId = "rotl"
-
--- | reverse function identifier
-rotrId :: String
-rotrId = "rotr"
-
--- | concatenate the vectors in a vector
-concatId :: String
-concatId = "concat"
-
--- | reverse function identifier
-reverseId :: String
-reverseId = "reverse"
-
--- | iterate function identifier
-iterateId :: String
-iterateId = "iterate"
-
--- | iteraten function identifier
-iteratenId :: String
-iteratenId = "iteraten"
-
--- | iterate function identifier
-generateId :: String
-generateId = "generate"
-
--- | iteraten function identifier
-generatenId :: String
-generatenId = "generaten"
-
--- | copy function identifier
-copyId :: String
-copyId = "copy"
-
--- | copyn function identifier
-copynId :: String
-copynId = "copyn"
-
--- | map function identifier
-mapId :: String
-mapId = "map"
-
--- | zipwith function identifier
-zipWithId :: String
-zipWithId = "zipWith"
-
--- | foldl function identifier
-foldlId :: String
-foldlId = "foldl"
-
--- | foldr function identifier
-foldrId :: String
-foldrId = "foldr"
-
--- | zip function identifier
-zipId :: String
-zipId = "zip"
-
--- | unzip function identifier
-unzipId :: String
-unzipId = "unzip"
-
--- | hwxor function identifier
-hwxorId :: String
-hwxorId = "hwxor"
-
--- | hwor function identifier
-hworId :: String
-hworId = "hwor"
-
--- | hwnot function identifier
-hwnotId :: String
-hwnotId = "hwnot"
-
--- | hwand function identifier
-hwandId :: String
-hwandId = "hwand"
-
-lengthTId :: String
-lengthTId = "lengthT"
-
--- Numeric Operations
-
--- | plus operation identifier
-plusId :: String
-plusId = "+"
-
--- | times operation identifier
-timesId :: String
-timesId = "*"
-
--- | negate operation identifier
-negateId :: String
-negateId = "negate"
-
--- | minus operation identifier
-minusId :: String
-minusId = "-"
-
--- | convert sizedword to ranged
-fromSizedWordId :: String
-fromSizedWordId = "fromSizedWord"
-
-toIntegerId :: String
-toIntegerId = "to_integer"
-
-fromIntegerId :: String
-fromIntegerId = "fromInteger"
-
-toSignedId :: String
-toSignedId = "to_signed"
-
-toUnsignedId :: String
-toUnsignedId = "to_unsigned"
-
-resizeId :: String
-resizeId = "resize"
-
-------------------
--- VHDL type marks
-------------------
-
--- | The Bit type mark
-bitTM :: AST.TypeMark
-bitTM = AST.unsafeVHDLBasicId "Bit"
-
--- | Stardard logic type mark
-std_logicTM :: AST.TypeMark
-std_logicTM = AST.unsafeVHDLBasicId "std_logic"
-
--- | boolean type mark
-booleanTM :: AST.TypeMark
-booleanTM = AST.unsafeVHDLBasicId "boolean"
-
--- | fsvec_index AST. TypeMark
-tfvec_indexTM :: AST.TypeMark
-tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
-
--- | natural AST. TypeMark
-naturalTM :: AST.TypeMark
-naturalTM = AST.unsafeVHDLBasicId "natural"
-
--- | integer TypeMark
-integerTM :: AST.TypeMark
-integerTM = AST.unsafeVHDLBasicId "integer"
-
--- | signed TypeMark
-signedTM :: AST.TypeMark
-signedTM = AST.unsafeVHDLBasicId "signed"
-
--- | unsigned TypeMark
-unsignedTM :: AST.TypeMark
-unsignedTM = AST.unsafeVHDLBasicId "unsigned"
+++ /dev/null
-{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
-module CoreShow where
-
--- This module derives Show instances for CoreSyn types.
-
-import qualified BasicTypes
-
-import qualified CoreSyn
-import qualified TypeRep
-import qualified TyCon
-
-import qualified HsTypes
-import qualified HsExpr
-import qualified HsBinds
-import qualified SrcLoc
-import qualified RdrName
-
-import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
-
-
--- Derive Show for core expressions and binders, so we can see the actual
--- structure.
-deriving instance (Show b) => Show (CoreSyn.Expr b)
-deriving instance (Show b) => Show (CoreSyn.Bind b)
-deriving instance Show TypeRep.Type
-deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n)
-deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n)
-deriving instance (Show x) => Show (SrcLoc.Located x)
-deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x)
-deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x)
-deriving instance Show (RdrName.RdrName)
-deriving instance (Show idL, Show idR, OutputableBndr idL, OutputableBndr idR) => Show (HsBinds.HsBindLR idL idR)
-deriving instance Show CoreSyn.Note
-
-
--- Implement dummy shows, since deriving them will need loads of other shows
--- as well.
-instance Show TypeRep.PredType where
- show t = "_PredType:(" ++ (showSDoc $ ppr t) ++ ")"
-instance Show TyCon.TyCon where
- show t = "_TyCon:(" ++ (showSDoc $ ppr t) ++ ")"
-instance Show BasicTypes.Boxity where
- show b = "_Boxity"
-instance Show HsTypes.HsExplicitForAll where
- show b = "_HsExplicitForAll"
-instance Show HsExpr.HsArrAppType where
- show b = "_HsArrAppType"
-instance Show (HsExpr.MatchGroup x) where
- show b = "_HsMatchGroup"
-instance Show (HsExpr.GroupByClause x) where
- show b = "_GroupByClause"
-instance Show (HsExpr.HsStmtContext x) where
- show b = "_HsStmtContext"
-instance Show (HsBinds.Prag) where
- show b = "_Prag"
-instance Show (HsExpr.GRHSs id) where
- show b = "_GRHSs"
-
-
-instance (Outputable x) => Show x where
- show x = "__" ++ (showSDoc $ ppr x) ++ "__"
+++ /dev/null
--- | This module provides a number of functions to find out things about Core
--- programs. This module does not provide the actual plumbing to work with
--- Core and Haskell (it uses HsTools for this), but only the functions that
--- know about various libraries and know which functions to call.
-module CoreTools where
-
---Standard modules
-import qualified Maybe
-import System.IO.Unsafe
-
--- GHC API
-import qualified GHC
-import qualified Type
-import qualified TcType
-import qualified HsExpr
-import qualified HsTypes
-import qualified HsBinds
-import qualified HscTypes
-import qualified RdrName
-import qualified Name
-import qualified OccName
-import qualified TysWiredIn
-import qualified Bag
-import qualified DynFlags
-import qualified SrcLoc
-import qualified CoreSyn
-import qualified Var
-import qualified VarSet
-import qualified Unique
-import qualified CoreUtils
-import qualified CoreFVs
-import qualified Literal
-
--- Local imports
-import GhcTools
-import HsTools
-import Pretty
-
--- | Evaluate a core Type representing type level int from the tfp
--- library to a real int.
-eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
-eval_tfp_int env ty =
- unsafeRunGhc $ do
- GHC.setSession env
- -- Automatically import modules for any fully qualified identifiers
- setDynFlag DynFlags.Opt_ImplicitImportQualified
-
- let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
- let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
- let undef = hsTypedUndef $ coreToHsType ty
- let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
- let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
- let expr = HsExpr.ExprWithTySig app int_ty
- core <- toCore expr
- execCore core
-
-normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
-normalise_tfp_int env ty =
- unsafePerformIO $ do
- nty <- normaliseType env ty
- return nty
-
--- | Get the width of a SizedWord type
--- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
-
-sized_word_len_ty :: Type.Type -> Type.Type
-sized_word_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
- [len] = args
-
--- | Get the width of a SizedInt type
--- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
--- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
-
-sized_int_len_ty :: Type.Type -> Type.Type
-sized_int_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
- [len] = args
-
--- | Get the upperbound of a RangedWord type
--- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
--- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
-
-ranged_word_bound_ty :: Type.Type -> Type.Type
-ranged_word_bound_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
- [len] = args
-
--- | Evaluate a core Type representing type level int from the TypeLevel
--- library to a real int.
--- eval_type_level_int :: Type.Type -> Int
--- eval_type_level_int ty =
--- unsafeRunGhc $ do
--- -- Automatically import modules for any fully qualified identifiers
--- setDynFlag DynFlags.Opt_ImplicitImportQualified
---
--- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
--- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
--- let undef = hsTypedUndef $ coreToHsType ty
--- let app = HsExpr.HsApp (to_int) (undef)
---
--- core <- toCore [] app
--- execCore core
-
--- | Get the length of a FSVec type
--- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
--- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
-
-tfvec_len_ty :: Type.Type -> Type.Type
-tfvec_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
- [len, el_ty] = args
-
--- | Get the element type of a TFVec type
-tfvec_elem :: Type.Type -> Type.Type
-tfvec_elem ty = el_ty
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
- [len, el_ty] = args
-
--- Is the given core expression a lambda abstraction?
-is_lam :: CoreSyn.CoreExpr -> Bool
-is_lam (CoreSyn.Lam _ _) = True
-is_lam _ = False
-
--- Is the given core expression of a function type?
-is_fun :: CoreSyn.CoreExpr -> Bool
--- Treat Type arguments differently, because exprType is not defined for them.
-is_fun (CoreSyn.Type _) = False
-is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
-
--- Is the given core expression polymorphic (i.e., does it accept type
--- arguments?).
-is_poly :: CoreSyn.CoreExpr -> Bool
--- Treat Type arguments differently, because exprType is not defined for them.
-is_poly (CoreSyn.Type _) = False
-is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
-
--- Is the given core expression a variable reference?
-is_var :: CoreSyn.CoreExpr -> Bool
-is_var (CoreSyn.Var _) = True
-is_var _ = False
-
-is_lit :: CoreSyn.CoreExpr -> Bool
-is_lit (CoreSyn.Lit _) = True
-is_lit _ = False
-
--- Can the given core expression be applied to something? This is true for
--- applying to a value as well as a type.
-is_applicable :: CoreSyn.CoreExpr -> Bool
-is_applicable expr = is_fun expr || is_poly expr
-
--- Is the given core expression a variable or an application?
-is_simple :: CoreSyn.CoreExpr -> Bool
-is_simple (CoreSyn.App _ _) = True
-is_simple (CoreSyn.Var _) = True
-is_simple (CoreSyn.Cast expr _) = is_simple expr
-is_simple _ = False
-
--- Does the given CoreExpr have any free type vars?
-has_free_tyvars :: CoreSyn.CoreExpr -> Bool
-has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
-
--- Does the given CoreExpr have any free local vars?
-has_free_vars :: CoreSyn.CoreExpr -> Bool
-has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
-
--- Turns a Var CoreExpr into the Id inside it. Will of course only work for
--- simple Var CoreExprs, not complexer ones.
-exprToVar :: CoreSyn.CoreExpr -> Var.Id
-exprToVar (CoreSyn.Var id) = id
-exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
-
--- Turns a Lit CoreExpr into the Literal inside it.
-exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
-exprToLit (CoreSyn.Lit lit) = lit
-exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
-
--- Removes all the type and dictionary arguments from the given argument list,
--- leaving only the normal value arguments. The type given is the type of the
--- expression applied to this argument list.
-get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
-get_val_args ty args = drop n args
- where
- (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
- -- The first (length tyvars) arguments should be types, the next
- -- (length predtypes) arguments should be dictionaries. We drop this many
- -- arguments, to get at the value arguments.
- n = length tyvars + length predtypes
-
-getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals app@(CoreSyn.App _ _) = literals
- where
- (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- literals = filter (is_lit) args
+++ /dev/null
-{-# LANGUAGE PackageImports #-}
-
-module Generate where
-
--- Standard modules
-import qualified Control.Monad as Monad
-import qualified Data.Map as Map
-import qualified Maybe
-import qualified Data.Either as Either
-import qualified Control.Monad.Trans.State as State
-import qualified "transformers" Control.Monad.Identity as Identity
-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 Type
-import qualified Var
-import qualified IdInfo
-import qualified Literal
-import qualified Name
-import qualified TyCon
-
--- Local imports
-import Constants
-import VHDLTypes
-import VHDLTools
-import CoreTools
-import Pretty
-
------------------------------------------------------------------------------
--- Functions to generate VHDL for builtin functions
------------------------------------------------------------------------------
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be expressions.
-genExprArgs wrap dst func args = do
- args' <- eitherCoreOrExprArgs args
- wrap dst func args'
-
-eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be variables.
-genVarArgs ::
- (dst -> func -> [Var.Var] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genVarArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToVar exprargs
- -- Check (rather crudely) that all arguments are CoreExprs
- (exprargs, []) = Either.partitionEithers args
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be Literals
-genLitArgs ::
- (dst -> func -> [Literal.Literal] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genLitArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToLit litargs
- -- FIXME: Check if we were passed an CoreSyn.App
- litargs = concat (map getLiterals exprargs)
- (exprargs, []) = Either.partitionEithers args
-
--- | A function to wrap a builder-like function that produces an expression
--- and expects it to be assigned to the destination.
-genExprRes ::
- ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
- -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
-genExprRes wrap dst func args = do
- expr <- wrap dst func args
- return $ [mkUncondAssign dst expr]
-
--- | Generate a binary operator application. The first argument should be a
--- constructor from the AST.Expr type, e.g. AST.And.
-genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
-genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
-
--- | Generate a unary operator application
-genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
-genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genOperator1' op _ f [arg] = return $ op arg
-
--- | Generate a unary operator application
-genNegation :: BuiltinBuilder
-genNegation = genVarArgs $ genExprRes genNegation'
-genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
-genNegation' _ f [arg] = do
- arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
- let ty = Var.varType arg
- let (tycon, args) = Type.splitTyConApp ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "SizedInt" -> return $ AST.Neg arg1
- otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
-
--- | Generate a function call from the destination binder, function name and a
--- list of expressions (its arguments)
-genFCall :: Bool -> BuiltinBuilder
-genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
-genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genFCall' switch (Left res) f args = do
- let fname = varToString f
- let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
- id <- MonadState.lift vsType $ vectorFunId el_ty fname
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genFromSizedWord' (Left res) f args = do
- let fname = varToString f
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genResize :: BuiltinBuilder
-genResize = genExprArgs $ genExprRes genResize'
-genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genResize' (Left res) f [arg] = do {
- ; let { ty = Var.varType res
- ; (tycon, args) = Type.splitTyConApp ty
- ; name = Name.getOccString (TyCon.tyConName tycon)
- } ;
- ; len <- case name of
- "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
- [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- }
-genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
--- FIXME: I'm calling genLitArgs which is very specific function,
--- which needs to be fixed as well
-genFromInteger :: BuiltinBuilder
-genFromInteger = genLitArgs $ genExprRes genFromInteger'
-genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
-genFromInteger' (Left res) f lits = do {
- ; let { ty = Var.varType res
- ; (tycon, args) = Type.splitTyConApp ty
- ; name = Name.getOccString (TyCon.tyConName tycon)
- } ;
- ; len <- case name of
- "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
- ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- }
-
-genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-
--- | Generate a generate statement for the builtin function "map"
-genMap :: BuiltinBuilder
-genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
- -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
- -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
- -- we must index it (which we couldn't if it was a VHDL Expr, since only
- -- VHDLNames can be indexed).
- -- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- ; resname = mkIndexedName (varToVHDLName res) n_expr
- ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
- ; valargs = get_val_args (Var.varType real_f) already_mapped_args
- } ;
- ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
- -- Return the generate statement
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
- }
-
-genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
-
-genZipWith :: BuiltinBuilder
-genZipWith = genVarArgs genZipWith'
-genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the zipped_f to
- -- each of the elements in arg1 and arg2, storing to each element in res
- ; resname = mkIndexedName (varToVHDLName res) n_expr
- ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- } ;
- ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
- }
-
-genFoldl :: BuiltinBuilder
-genFoldl = genFold True
-
-genFoldr :: BuiltinBuilder
-genFoldr = genFold False
-
-genFold :: Bool -> BuiltinBuilder
-genFold left = genVarArgs (genFold' left)
-
-genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genFold' left res f args@[folded_f , start ,vec]= do
- len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
- genFold'' len left res f args
-
-genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
--- Special case for an empty input vector, just assign start to res
-genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
- arg <- MonadState.lift vsType $ varToVHDLExpr start
- return [mkUncondAssign (Left res) arg]
-
-genFold'' len left (Left res) f [folded_f, start, vec] = do
- -- The vector length
- --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- -- An expression for len-1
- let len_min_expr = (AST.PrimLit $ show (len-1))
- -- evec is (TFVec n), so it still needs an element type
- let (nvec, _) = splitAppTy (Var.varType vec)
- -- Put the type of the start value in nvec, this will be the type of our
- -- temporary vector
- let tmp_ty = Type.mkAppTy nvec (Var.varType start)
- let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
- -- Setup the generate scheme
- let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
- let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
- let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
- else AST.DownRange len_min_expr (AST.PrimLit "0")
- let gen_scheme = AST.ForGn n_id gen_range
- -- Make the intermediate vector
- let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
- -- Create the generate statement
- cells <- sequence [genFirstCell, genOtherCell]
- let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
- -- Assign tmp[len-1] or tmp[0] to res
- let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
- (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
- (mkIndexedName tmp_name (AST.PrimLit "0")))
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return [AST.CSBSm block]
- where
- -- An id for the counter
- n_id = mkVHDLBasicId "n"
- n_cur = idToVHDLExpr n_id
- -- An expression for previous n
- n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
- else (n_cur AST.:+: (AST.PrimLit "1"))
- -- An id for the tmp result vector
- tmp_id = mkVHDLBasicId "tmp"
- tmp_name = AST.NSimple tmp_id
- -- Generate parts of the fold
- genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
- genFirstCell = do
- len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- let cond_label = mkVHDLExtId "firstcell"
- -- if n == 0 or n == len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
- else (AST.PrimLit $ show (len-1)))
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from start
- argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
- -- Input from vec[current n]
- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- app_concsms <- genApplication (Right resname) folded_f ( if left then
- [Right argexpr1, Right argexpr2]
- else
- [Right argexpr2, Right argexpr1]
- )
- -- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
-
- genOtherCell = do
- len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- let cond_label = mkVHDLExtId "othercell"
- -- if n > 0 or n < len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
- else (AST.PrimLit $ show (len-1)))
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from tmp[previous n]
- let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- -- Input from vec[current n]
- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- app_concsms <- genApplication (Right resname) folded_f ( if left then
- [Right argexpr1, Right argexpr2]
- else
- [Right argexpr2, Right argexpr1]
- )
- -- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
-
--- | Generate a generate statement for the builtin function "zip"
-genZip :: BuiltinBuilder
-genZip = genVarArgs genZip'
-genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genZip' (Left res) f args@[arg1, arg2] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- ; resname' = mkIndexedName (varToVHDLName res) n_expr
- ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- } ;
- ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
- ; let { resnameA = mkSelectedName resname' (labels!!0)
- ; resnameB = mkSelectedName resname' (labels!!1)
- ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
- ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
- } ;
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
- }
-
--- | Generate a generate statement for the builtin function "unzip"
-genUnzip :: BuiltinBuilder
-genUnzip = genVarArgs genUnzip'
-genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genUnzip' (Left res) f args@[arg] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- ; resname' = varToVHDLName res
- ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
- } ;
- ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
- ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
- ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
- ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
- ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
- ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
- ; resA_assign = mkUncondAssign (Right resnameA) argexprA
- ; resB_assign = mkUncondAssign (Right resnameB) argexprB
- } ;
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
- }
-
-genCopy :: BuiltinBuilder
-genCopy = genVarArgs genCopy'
-genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genCopy' (Left res) f args@[arg] =
- let
- resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ (varToVHDLName arg))]
- out_assign = mkUncondAssign (Left res) resExpr
- in
- return [out_assign]
-
-genConcat :: BuiltinBuilder
-genConcat = genVarArgs genConcat'
-genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genConcat' (Left res) f args@[arg] = do {
- -- Setup the generate scheme
- ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- ; let (_, nvec) = splitAppTy (Var.varType arg)
- ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
- ; resname = vecSlice fromRange toRange
- ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- ; out_assign = mkUncondAssign (Right resname) argexpr
- } ;
- -- Return the generate statement
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
- }
- where
- vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
- (AST.ToRange init last))
-
-genIteraten :: BuiltinBuilder
-genIteraten dst f args = genIterate dst f (tail args)
-
-genIterate :: BuiltinBuilder
-genIterate = genIterateOrGenerate True
-
-genGeneraten :: BuiltinBuilder
-genGeneraten dst f args = genGenerate dst f (tail args)
-
-genGenerate :: BuiltinBuilder
-genGenerate = genIterateOrGenerate False
-
-genIterateOrGenerate :: Bool -> BuiltinBuilder
-genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
-
-genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genIterateOrGenerate' iter (Left res) f args = do
- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
- genIterateOrGenerate'' len iter (Left res) f args
-
-genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
--- Special case for an empty input vector, just assign start to res
-genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
-
-genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
- -- The vector length
- -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
- -- An expression for len-1
- let len_min_expr = (AST.PrimLit $ show (len-1))
- -- -- evec is (TFVec n), so it still needs an element type
- -- let (nvec, _) = splitAppTy (Var.varType vec)
- -- -- Put the type of the start value in nvec, this will be the type of our
- -- -- temporary vector
- let tmp_ty = Var.varType res
- let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
- -- Setup the generate scheme
- let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
- let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
- let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
- let gen_scheme = AST.ForGn n_id gen_range
- -- Make the intermediate vector
- let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
- -- Create the generate statement
- cells <- sequence [genFirstCell, genOtherCell]
- let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
- -- Assign tmp[len-1] or tmp[0] to res
- let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return [AST.CSBSm block]
- where
- -- An id for the counter
- n_id = mkVHDLBasicId "n"
- n_cur = idToVHDLExpr n_id
- -- An expression for previous n
- n_prev = n_cur AST.:-: (AST.PrimLit "1")
- -- An id for the tmp result vector
- tmp_id = mkVHDLBasicId "tmp"
- tmp_name = AST.NSimple tmp_id
- -- Generate parts of the fold
- genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
- genFirstCell = do
- let cond_label = mkVHDLExtId "firstcell"
- -- if n == 0 or n == len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from start
- argexpr <- MonadState.lift vsType $ varToVHDLExpr start
- let startassign = mkUncondAssign (Right resname) argexpr
- app_concsms <- genApplication (Right resname) app_f [Right argexpr]
- -- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
- [startassign]
- else
- app_concsms
- )
-
- genOtherCell = do
- let cond_label = mkVHDLExtId "othercell"
- -- if n > 0 or n < len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from tmp[previous n]
- let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- app_concsms <- genApplication (Right resname) app_f [Right argexpr]
- -- Return the conditional generate part
- return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
-
-
------------------------------------------------------------------------------
--- Function to generate VHDL for applications
------------------------------------------------------------------------------
-genApplication ::
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
- -> CoreSyn.CoreBndr -- ^ The function to apply
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
- -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
-genApplication dst f args = 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.
- case (Map.lookup f signatures) of
- Just signature -> do
- args' <- eitherCoreOrExprArgs args
- -- We have a signature, this is a top level binding. Generate a
- -- component instantiation.
- let entity_id = ent_id signature
- -- TODO: Using show here isn't really pretty, but we'll need some
- -- unique-ish value...
- let label = "comp_ins_" ++ (either show prettyShow) dst
- let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
- return [mkComponentInst label entity_id portmaps]
- Nothing -> do
- -- No signature, so this must be a local variable reference. It
- -- should have a representable type (and thus, no arguments) and a
- -- signal should be generated for it. Just generate an
- -- unconditional assignment here.
- f' <- MonadState.lift vsType $ varToVHDLExpr f
- return $ [mkUncondAssign dst f']
- 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.
------------------------------------------------------------------------------
-
--- Returns the VHDLId of the vector function with the given name for the given
--- element type. Generates -- this function if needed.
-vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
-vectorFunId el_ty fname = do
- let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
- elemTM <- vhdl_ty error_msg el_ty
- -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
- -- the VHDLState or something.
- let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
- typefuns <- getA vsTypeFuns
- case Map.lookup (OrdType el_ty, fname) typefuns of
- -- Function already generated, just return it
- Just (id, _) -> return id
- -- Function not generated yet, generate it
- Nothing -> do
- let functions = genUnconsVectorFuns elemTM vectorTM
- case lookup fname functions of
- Just body -> do
- modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
- mapM_ (vectorFunId el_ty) (snd body)
- return function_id
- Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
- where
- function_id = mkVHDLExtId fname
-
-genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
- -> AST.TypeMark -- ^ type of the vector
- -> [(String, (AST.SubProgBody, [String]))]
-genUnconsVectorFuns elemTM vectorTM =
- [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
- , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
- , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
- , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
- , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
- , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
- , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
- , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
- , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
- , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
- , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
- , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
- , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
- , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
- , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
- , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
- , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
- , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
- , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
- , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
- , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
- , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
- ]
- where
- ixPar = AST.unsafeVHDLBasicId "ix"
- vecPar = AST.unsafeVHDLBasicId "vec"
- vec1Par = AST.unsafeVHDLBasicId "vec1"
- vec2Par = AST.unsafeVHDLBasicId "vec2"
- nPar = AST.unsafeVHDLBasicId "n"
- iId = AST.unsafeVHDLBasicId "i"
- iPar = iId
- aPar = AST.unsafeVHDLBasicId "a"
- fPar = AST.unsafeVHDLBasicId "f"
- sPar = AST.unsafeVHDLBasicId "s"
- resId = AST.unsafeVHDLBasicId "res"
- exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec ixPar naturalTM] elemTM
- exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
- (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
- AST.NSimple ixPar]))
- replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
- , AST.IfaceVarDec iPar naturalTM
- , AST.IfaceVarDec aPar elemTM
- ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- replaceVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
- replaceExpr = AST.NSimple resId AST.:=
- (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
- AST.PrimName (AST.NSimple aPar) AST.:&:
- vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
- ((AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
- AST.:-: AST.PrimLit "1"))
- replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- vecSlice init last = AST.PrimName (AST.NSlice
- (AST.SliceName
- (AST.NSimple vecPar)
- (AST.ToRange init last)))
- headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
- -- return vec(0);
- headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
- (AST.NSimple vecPar) [AST.PrimLit "0"])))
- lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
- -- return vec(vec'length-1);
- lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
- (AST.NSimple vecPar)
- [AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"])))
- initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-2);
- initVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "2")) ]))
- Nothing
- -- resAST.:= vec(0 to vec'length-2)
- initExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "2"))
- initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-2);
- tailVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "2")) ]))
- Nothing
- -- res AST.:= vec(1 to vec'length-1)
- tailExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimLit "1")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"))
- tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to n-1);
- takeVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- ((AST.PrimName (AST.NSimple nPar)) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(0 to n-1)
- takeExpr = AST.NSimple resId AST.:=
- (vecSlice (AST.PrimLit "1")
- (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
- takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-n-1);
- dropVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(n to vec'length-1)
- dropExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimName $ AST.NSimple nPar)
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"))
- dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
- AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length);
- plusgtVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
- Nothing
- plusgtExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple aPar) AST.:&:
- (AST.PrimName $ AST.NSimple vecPar))
- plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
- emptyVar =
- AST.ConstDec resId
- (AST.SubtypeIn vectorTM Nothing)
- (Just $ AST.PrimLit "\"\"")
- emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
- singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
- vectorTM
- -- variable res : fsvec_x (0 to 0) := (others => a);
- singletonVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
- (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ AST.NSimple aPar)])
- singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to n-1) := (others => a);
- copynVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- ((AST.PrimName (AST.NSimple nPar)) AST.:-:
- (AST.PrimLit "1")) ]))
- (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ AST.NSimple aPar)])
- -- return res
- copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
- AST.IfaceVarDec sPar naturalTM,
- AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to n-1);
- selVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- ((AST.PrimName (AST.NSimple nPar)) AST.:-:
- (AST.PrimLit "1")) ])
- )
- Nothing
- -- for i res'range loop
- -- res(i) := vec(f+i*s);
- -- end loop;
- selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
- -- res(i) := vec(f+i*s);
- selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
- (AST.PrimName (AST.NSimple iId) AST.:*:
- AST.PrimName (AST.NSimple sPar)) in
- AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
- (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
- -- return res;
- selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
- ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length);
- ltplusVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
- Nothing
- ltplusExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
- (AST.PrimName $ AST.NSimple aPar))
- ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
- AST.IfaceVarDec vec2Par vectorTM]
- vectorTM
- -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
- plusplusVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
- AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- AST.PrimLit "1")]))
- Nothing
- plusplusExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
- (AST.PrimName $ AST.NSimple vec2Par))
- plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
- lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
- shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- shiftlVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res := a & init(vec)
- shiftlExpr = AST.NSimple resId AST.:=
- (AST.PrimName (AST.NSimple aPar) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- shiftrVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res := tail(vec) & a
- shiftrExpr = AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimName (AST.NSimple aPar)))
-
- shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
- -- return vec'length = 0
- nullExpr = AST.ReturnSm (Just $
- AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
- AST.PrimLit "0")
- rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- rotlVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- if null(vec) then res := vec else res := last(vec) & init(vec)
- rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
- [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
- []
- (Just $ AST.Else [rotlExprRet])
- where rotlExprRet =
- AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- rotrVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- if null(vec) then res := vec else res := tail(vec) & head(vec)
- rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
- [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
- []
- (Just $ AST.Else [rotrExprRet])
- where rotrExprRet =
- AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- reverseVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- for i in 0 to res'range loop
- -- res(vec'length-i-1) := vec(i);
- -- end loop;
- reverseFor =
- AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
- -- res(vec'length-i-1) := vec(i);
- reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
- (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
- [AST.PrimName $ AST.NSimple iId]))
- where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
- (mkVHDLBasicId lengthId) Nothing) AST.:-:
- AST.PrimName (AST.NSimple iId) AST.:-:
- (AST.PrimLit "1")
- -- return res;
- reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
-
------------------------------------------------------------------------------
--- A table of builtin functions
------------------------------------------------------------------------------
-
--- | The builtin functions we support. Maps a name to an argument count and a
--- builder function.
-globalNameTable :: NameTable
-globalNameTable = Map.fromList
- [ (exId , (2, genFCall False ) )
- , (replaceId , (3, genFCall False ) )
- , (headId , (1, genFCall True ) )
- , (lastId , (1, genFCall True ) )
- , (tailId , (1, genFCall False ) )
- , (initId , (1, genFCall False ) )
- , (takeId , (2, genFCall False ) )
- , (dropId , (2, genFCall False ) )
- , (selId , (4, genFCall False ) )
- , (plusgtId , (2, genFCall False ) )
- , (ltplusId , (2, genFCall False ) )
- , (plusplusId , (2, genFCall False ) )
- , (mapId , (2, genMap ) )
- , (zipWithId , (3, genZipWith ) )
- , (foldlId , (3, genFoldl ) )
- , (foldrId , (3, genFoldr ) )
- , (zipId , (2, genZip ) )
- , (unzipId , (1, genUnzip ) )
- , (shiftlId , (2, genFCall False ) )
- , (shiftrId , (2, genFCall False ) )
- , (rotlId , (1, genFCall False ) )
- , (rotrId , (1, genFCall False ) )
- , (concatId , (1, genConcat ) )
- , (reverseId , (1, genFCall False ) )
- , (iteratenId , (3, genIteraten ) )
- , (iterateId , (2, genIterate ) )
- , (generatenId , (3, genGeneraten ) )
- , (generateId , (2, genGenerate ) )
- , (emptyId , (0, genFCall False ) )
- , (singletonId , (1, genFCall False ) )
- , (copynId , (2, genFCall False ) )
- , (copyId , (1, genCopy ) )
- , (lengthTId , (1, genFCall False ) )
- , (nullId , (1, genFCall False ) )
- , (hwxorId , (2, genOperator2 AST.Xor ) )
- , (hwandId , (2, genOperator2 AST.And ) )
- , (hworId , (2, genOperator2 AST.Or ) )
- , (hwnotId , (1, genOperator1 AST.Not ) )
- , (plusId , (2, genOperator2 (AST.:+:) ) )
- , (timesId , (2, genOperator2 (AST.:*:) ) )
- , (negateId , (1, genNegation ) )
- , (minusId , (2, genOperator2 (AST.:-:) ) )
- , (fromSizedWordId , (1, genFromSizedWord ) )
- , (fromIntegerId , (1, genFromInteger ) )
- , (resizeId , (1, genResize ) )
- ]
+++ /dev/null
-module GhcTools where
--- Standard modules
-import qualified System.IO.Unsafe
-
--- GHC API
-import qualified GHC
-import qualified GHC.Paths
-import qualified DynFlags
-import qualified TcRnMonad
-import qualified MonadUtils
-import qualified HscTypes
-import qualified PrelNames
-
--- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
--- be no standard function to do exactly this.
-setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
-setDynFlag dflag = do
- dflags <- GHC.getSessionDynFlags
- let dflags' = DynFlags.dopt_set dflags dflag
- GHC.setSessionDynFlags dflags'
- return ()
-
--- We don't want the IO monad sprinkled around everywhere, so we hide it.
--- This should be safe as long as we only do simple things in the GhcMonad
--- such as interface lookups and evaluating simple expressions that
--- don't have side effects themselves (Or rather, that don't use
--- unsafePerformIO themselves, since normal side effectful function would
--- just return an IO monad when they are evaluated).
-unsafeRunGhc :: GHC.Ghc a -> a
-unsafeRunGhc m =
- System.IO.Unsafe.unsafePerformIO $
- GHC.runGhc (Just GHC.Paths.libdir) $ do
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- m
-
-runTcM :: TcRnMonad.TcM a -> IO a
-runTcM thing_inside = do
- GHC.runGhc (Just GHC.Paths.libdir) $ do
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- env <- GHC.getSession
- HscTypes.ioMsgMaybe . MonadUtils.liftIO . TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
- thing_inside
+++ /dev/null
-{-# LANGUAGE ViewPatterns #-}
-module HsTools where
-
--- Standard modules
-import qualified Unsafe.Coerce
-import qualified Maybe
-
--- GHC API
-import qualified GHC
-import qualified HscMain
-import qualified HscTypes
-import qualified DynFlags
-import qualified FastString
-import qualified StringBuffer
-import qualified MonadUtils
-import Outputable ( showSDoc, ppr )
-import qualified Outputable
--- Lexer & Parser, i.e. up to HsExpr
-import qualified Lexer
-import qualified Parser
--- HsExpr representation, renaming, typechecking and desugaring
--- (i.e., everything up to Core).
-import qualified HsSyn
-import qualified HsExpr
-import qualified HsTypes
-import qualified HsBinds
-import qualified TcRnMonad
-import qualified TcRnTypes
-import qualified RnExpr
-import qualified RnEnv
-import qualified TcExpr
-import qualified TcEnv
-import qualified TcSimplify
-import qualified TcTyFuns
-import qualified Desugar
-import qualified InstEnv
-import qualified FamInstEnv
-import qualified PrelNames
-import qualified Module
-import qualified OccName
-import qualified RdrName
-import qualified Name
-import qualified TysWiredIn
-import qualified SrcLoc
-import qualified LoadIface
-import qualified BasicTypes
-import qualified Bag
--- Core representation and handling
-import qualified CoreSyn
-import qualified Id
-import qualified Type
-import qualified TyCon
-
-
--- Local imports
-import GhcTools
-import CoreShow
-
--- | Translate a HsExpr to a Core expression. This does renaming, type
--- checking, simplification of class instances and desugaring. The result is
--- a let expression that holds the given expression and a number of binds that
--- are needed for any type classes used to work. For example, the HsExpr:
--- \x = x == (1 :: Int)
--- will result in the CoreExpr
--- let
--- $dInt = ...
--- (==) = Prelude.(==) Int $dInt
--- in
--- \x = (==) x 1
-toCore ::
- HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
- -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
-toCore expr = do
- env <- GHC.getSession
- let icontext = HscTypes.hsc_IC env
-
- (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
- -- Translage the TcRn (typecheck-rename) monad into an IO monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
- (tc_expr, insts) <- TcRnMonad.getLIE $ do
- -- Rename the expression, resulting in a HsExpr Name
- (rn_expr, freevars) <- RnExpr.rnExpr expr
- -- Typecheck the expression, resulting in a HsExpr Id and a list of
- -- Insts
- (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
- return res
- -- Translate the instances into bindings
- --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
- binds <- TcSimplify.tcSimplifyTop insts
- return (binds, tc_expr)
-
- -- Create a let expression with the extra binds (for polymorphism etc.) and
- -- the resulting expression.
- let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
- (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
- tc_expr
- -- Desugar the expression, resulting in core.
- let rdr_env = HscTypes.ic_rn_gbl_env icontext
- desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
-
- return desugar_expr
-
--- | Create an Id from a RdrName. Might not work for DataCons...
-mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
-mkId rdr_name = do
- env <- GHC.getSession
- id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
- -- Translage the TcRn (typecheck-rename) monad in an IO monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
- -- Automatically import all available modules, so fully qualified names
- -- always work
- TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
- -- Lookup a Name for the RdrName. This finds the package (version) in
- -- which the name resides.
- name <- RnEnv.lookupGlobalOccRn rdr_name
- -- Lookup an Id for the Name. This finds out the the type of the thing
- -- we're looking for.
- --
- -- Note that tcLookupId doesn't seem to work for DataCons. See source for
- -- tcLookupId to find out.
- TcEnv.tcLookupId name
- return id
-
-normaliseType ::
- HscTypes.HscEnv
- -> Type.Type
- -> IO Type.Type
-normaliseType env ty = do
- (err, nty) <- MonadUtils.liftIO $
- -- Initialize the typechecker monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
- -- Normalize the type
- (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
- return nty
- let normalized_ty = Maybe.fromJust nty
- return normalized_ty
-
--- | Translate a core Type to an HsType. Far from complete so far.
-coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
--- Translate TyConApps
-coreToHsType ty = case Type.splitTyConApp_maybe ty of
- Just (tycon, tys) ->
- foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
- where
- tycon_name = TyCon.tyConName tycon
- mod_name = Module.moduleName $ Name.nameModule tycon_name
- occ_name = Name.nameOccName tycon_name
- tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
- tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
- Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
-
--- | Evaluate a CoreExpr and return its value. For this to work, the caller
--- should already know the result type for sure, since the result value is
--- unsafely coerced into this type.
-execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
-execCore expr = do
- -- Setup session flags (yeah, this seems like a noop, but
- -- setSessionDynFlags really does some extra work...)
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- -- Compile the expressions. This runs in the IO monad, but really wants
- -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
- -- understand what it means, but it works.
- env <- GHC.getSession
- let srcspan = SrcLoc.noSrcSpan
- hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
- let res = Unsafe.Coerce.unsafeCoerce hval :: Int
- return $ Unsafe.Coerce.unsafeCoerce hval
-
--- These functions build (parts of) a LHSExpr RdrName.
-
--- | A reference to the Prelude.undefined function.
-hsUndef :: HsExpr.LHsExpr RdrName.RdrName
-hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
-
--- | A typed reference to the Prelude.undefined function.
-hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
-hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
-
--- | Create a qualified RdrName from a module name and a variable name
-mkRdrName :: String -> String -> RdrName.RdrName
-mkRdrName mod var =
- RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
-
--- These three functions are simplified copies of those in HscMain, because
--- those functions are not exported. These versions have all error handling
--- removed.
-hscParseType = hscParseThing Parser.parseType
-hscParseStmt = hscParseThing Parser.parseStmt
-
-hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
-hscParseThing parser dflags str = do
- buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
- let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
- let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
- return thing
-
--- | This function imports the module with the given name, for the renamer /
--- typechecker to use. It also imports any "orphans" and "family instances"
--- from modules included by this module, but not the actual modules
--- themselves. I'm not 100% sure how this works, but it seems that any
--- functions defined in included modules are available just by loading the
--- original module, and by doing this orphan stuff, any (type family or class)
--- instances are available as well.
---
--- Most of the code is based on tcRnImports and rnImportDecl, but those
--- functions do a lot more (which I hope we won't need...).
-importModule :: Module.ModuleName -> TcRnTypes.RnM ()
-importModule mod = do
- let reason = Outputable.text "Hardcoded import" -- Used for trace output
- let pkg = Nothing
- -- Load the interface.
- iface <- LoadIface.loadSrcInterface reason mod False pkg
- -- Load orphan an familiy instance dependencies as well. I think these
- -- dependencies are needed for the type checker to know all instances. Any
- -- other instances (on other packages) are only useful to the
- -- linker, so we can probably safely ignore them here. Dependencies within
- -- the same package are also listed in deps, but I'm not so sure what to do
- -- with them.
- let deps = HscTypes.mi_deps iface
- let orphs = HscTypes.dep_orphs deps
- let finsts = HscTypes.dep_finsts deps
- LoadIface.loadOrphanModules orphs False
- LoadIface.loadOrphanModules finsts True
+++ /dev/null
-Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
- * Neither the name of the copyright holder nor the
- names of its contributors may be used to endorse or promote products
- derived from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
-BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
-IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE PackageImports #-}
---
--- Functions to bring a Core expression in normal form. This module provides a
--- top level function "normalize", and defines the actual transformation passes that
--- are performed.
---
-module Normalize (normalizeModule) where
-
--- Standard modules
-import Debug.Trace
-import qualified Maybe
-import qualified "transformers" Control.Monad.Trans as Trans
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Map as Map
-import qualified Data.Monoid as Monoid
-import Data.Accessor
-
--- GHC API
-import CoreSyn
-import qualified UniqSupply
-import qualified CoreUtils
-import qualified Type
-import qualified TcType
-import qualified Id
-import qualified Var
-import qualified VarSet
-import qualified NameSet
-import qualified CoreFVs
-import qualified CoreUtils
-import qualified MkCore
-import qualified HscTypes
-import Outputable ( showSDoc, ppr, nest )
-
--- Local imports
-import NormalizeTypes
-import NormalizeTools
-import VHDLTypes
-import CoreTools
-import Pretty
-
---------------------------------
--- Start of transformations
---------------------------------
-
---------------------------------
--- η abstraction
---------------------------------
-eta, etatop :: Transform
-eta expr | is_fun expr && not (is_lam expr) = do
- let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
- id <- mkInternalVar "param" arg_ty
- change (Lam id (App expr (Var id)))
--- Leave all other expressions unchanged
-eta e = return e
-etatop = notappargs ("eta", eta)
-
---------------------------------
--- β-reduction
---------------------------------
-beta, betatop :: Transform
--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
--- Propagate the application into the let
-beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
--- Propagate the application into each of the alternatives
-beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
- where
- alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
- ty' = CoreUtils.applyTypeToArg ty arg
--- Leave all other expressions unchanged
-beta expr = return expr
--- Perform this transform everywhere
-betatop = everywhere ("beta", beta)
-
---------------------------------
--- Cast propagation
---------------------------------
--- Try to move casts as much downward as possible.
-castprop, castproptop :: Transform
-castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
-castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
- where
- alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
--- Leave all other expressions unchanged
-castprop expr = return expr
--- Perform this transform everywhere
-castproptop = everywhere ("castprop", castprop)
-
---------------------------------
--- let recursification
---------------------------------
-letrec, letrectop :: Transform
-letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
--- Leave all other expressions unchanged
-letrec expr = return expr
--- Perform this transform everywhere
-letrectop = everywhere ("letrec", letrec)
-
---------------------------------
--- let simplification
---------------------------------
-letsimpl, letsimpltop :: Transform
--- Put the "in ..." value of a let in its own binding, but not when the
--- expression is applicable (to prevent loops with inlinefun).
-letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
- local_var <- Trans.lift $ is_local_var res
- if not local_var
- then do
- -- If the result is not a local var already (to prevent loops with
- -- ourselves), extract it.
- id <- mkInternalVar "foo" (CoreUtils.exprType res)
- let bind = (id, res)
- change $ Let (Rec (bind:binds)) (Var id)
- else
- -- If the result is already a local var, don't extract it.
- return expr
-
--- Leave all other expressions unchanged
-letsimpl expr = return expr
--- Perform this transform everywhere
-letsimpltop = everywhere ("letsimpl", letsimpl)
-
---------------------------------
--- let flattening
---------------------------------
-letflat, letflattop :: Transform
-letflat (Let (Rec binds) expr) = do
- -- Turn each binding into a list of bindings (possibly containing just one
- -- element, of course)
- bindss <- Monad.mapM flatbind binds
- -- Concat all the bindings
- let binds' = concat bindss
- -- Return the new let. We don't use change here, since possibly nothing has
- -- changed. If anything has changed, flatbind has already flagged that
- -- change.
- return $ Let (Rec binds') expr
- where
- -- Turns a binding of a let into a multiple bindings, or any other binding
- -- into a list with just that binding
- flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
- flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
- flatbind (b, expr) = return [(b, expr)]
--- Leave all other expressions unchanged
-letflat expr = return expr
--- Perform this transform everywhere
-letflattop = everywhere ("letflat", letflat)
-
---------------------------------
--- Simple let binding removal
---------------------------------
--- Remove a = b bindings from let expressions everywhere
-letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
-
---------------------------------
--- Function inlining
---------------------------------
--- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
--- expressions everywhere. This means that any value that still needs to be
--- applied to something else (polymorphic values need to be applied to a
--- Type) will be inlined, and will eventually be applied to all their
--- arguments.
---
--- This is a tricky function, which is prone to create loops in the
--- transformations. To fix this, we make sure that no transformation will
--- create a new let binding with a function type. These other transformations
--- will just not work on those function-typed values at first, but the other
--- transformations (in particular β-reduction) should make sure that the type
--- of those values eventually becomes primitive.
-inlinenonreptop :: Transform
-inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
-
---------------------------------
--- Scrutinee simplification
---------------------------------
-scrutsimpl,scrutsimpltop :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
--- simple scrutinee, but not when the scrutinee is applicable (to prevent
--- loops with inlinefun, though I don't think a scrutinee can be
--- applicable...)
-scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
- id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
- change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
--- Leave all other expressions unchanged
-scrutsimpl expr = return expr
--- Perform this transform everywhere
-scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
-
---------------------------------
--- Case binder wildening
---------------------------------
-casewild, casewildtop :: Transform
-casewild expr@(Case scrut b ty alts) = do
- (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = concat bindingss
- -- Replace the case with a let with bindings and a case
- let newlet = (Let (Rec bindings) (Case scrut b ty alts'))
- -- If there are no non-wild binders, or this case is already a simple
- -- selector (i.e., a single alt with exactly one binding), already a simple
- -- selector altan no bindings (i.e., no wild binders in the original case),
- -- don't change anything, otherwise, replace the case.
- if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
- where
- -- Generate a single wild binder, since they are all the same
- wild = MkCore.mkWildBinder
- -- Wilden the binders of one alt, producing a list of bindings as a
- -- sideeffect.
- doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
- doalt (con, bndrs, expr) = do
- bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
- let bindings = Maybe.catMaybes bindings_maybe
- -- We replace the binders with wild binders only. We can leave expr
- -- unchanged, since the new bindings bind the same vars as the original
- -- did.
- let newalt = (con, wildbndrs, expr)
- return (bindings, newalt)
- where
- -- Make all binders wild
- wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
- -- A set of all the binders that are used by the expression
- free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
- -- Creates a case statement to retrieve the ith element from the scrutinee
- -- and binds that to b.
- mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
- mkextracts b i =
- if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
- -- Don't create extra bindings for binders that are already wild
- -- (e.g. not in the free variables of expr, so unused), or for
- -- binders that bind function types (to prevent loops with
- -- inlinefun).
- then return Nothing
- else do
- -- Create on new binder that will actually capture a value in this
- -- case statement, and return it
- let bty = (Id.idType b)
- id <- mkInternalVar "sel" bty
- let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- return $ Just (b, Case scrut b bty [(con, binders, Var id)])
--- Leave all other expressions unchanged
-casewild expr = return expr
--- Perform this transform everywhere
-casewildtop = everywhere ("casewild", casewild)
-
---------------------------------
--- Case value simplification
---------------------------------
-casevalsimpl, casevalsimpltop :: Transform
-casevalsimpl expr@(Case scrut b ty alts) = do
- -- Try to simplify each alternative, resulting in an optional binding and a
- -- new alternative.
- (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = Maybe.catMaybes bindings_maybe
- -- Create a new let around the case, that binds of the cases values.
- let newlet = Let (Rec bindings) (Case scrut b ty alts')
- -- If there were no values that needed and allowed simplification, don't
- -- change the case.
- if null bindings then return expr else change newlet
- where
- doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
- -- Don't simplify values that are already simple
- doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
- -- Simplify each alt by creating a new id, binding the case value to it and
- -- replacing the case value with that id. Only do this when the case value
- -- does not use any of the binders bound by this alternative, for that would
- -- cause those binders to become unbound when moving the value outside of
- -- the case statement. Also, don't create a binding for applicable
- -- expressions, to prevent loops with inlinefun.
- doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
- id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
- -- We don't flag a change here, since casevalsimpl will do that above
- -- based on Just we return here.
- return $ (Just (id, expr), (con, bndrs, Var id))
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
- -- Don't simplify anything else
- doalt alt = return (Nothing, alt)
--- Leave all other expressions unchanged
-casevalsimpl expr = return expr
--- Perform this transform everywhere
-casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
-
---------------------------------
--- Case removal
---------------------------------
--- Remove case statements that have only a single alternative and only wild
--- binders.
-caseremove, caseremovetop :: Transform
--- Replace a useless case by the value of its single alternative
-caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
--- Leave all other expressions unchanged
-caseremove expr = return expr
--- Perform this transform everywhere
-caseremovetop = everywhere ("caseremove", caseremove)
-
---------------------------------
--- Argument extraction
---------------------------------
--- Make sure that all arguments of a representable type are simple variables.
-appsimpl, appsimpltop :: Transform
--- Simplify all representable arguments. Do this by introducing a new Let
--- that binds the argument and passing the new binder in the application.
-appsimpl expr@(App f arg) = do
- -- Check runtime representability
- repr <- isRepr arg
- local_var <- Trans.lift $ is_local_var arg
- if repr && not local_var
- then do -- Extract representable arguments
- id <- mkInternalVar "arg" (CoreUtils.exprType arg)
- change $ Let (Rec [(id, arg)]) (App f (Var id))
- else -- Leave non-representable arguments unchanged
- return expr
--- Leave all other expressions unchanged
-appsimpl expr = return expr
--- Perform this transform everywhere
-appsimpltop = everywhere ("appsimpl", appsimpl)
-
---------------------------------
--- Function-typed argument propagation
---------------------------------
--- Remove all applications to function-typed arguments, by duplication the
--- function called with the function-typed parameter replaced by the free
--- variables of the argument passed in.
-argprop, argproptop :: Transform
--- Transform any application of a named function (i.e., skip applications of
--- lambda's). Also skip applications that have arguments with free type
--- variables, since we can't inline those.
-argprop expr@(App _ _) | is_var fexpr = do
- -- Find the body of the function called
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- Just body -> do
- -- Process each of the arguments in turn
- (args', changed) <- Writer.listen $ mapM doarg args
- -- See if any of the arguments changed
- case Monoid.getAny changed of
- True -> do
- let (newargs', newparams', oldargs) = unzip3 args'
- let newargs = concat newargs'
- let newparams = concat newparams'
- -- Create a new body that consists of a lambda for all new arguments and
- -- the old body applied to some arguments.
- let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
- -- Create a new function with the same name but a new body
- newf <- mkFunction f newbody
- -- Replace the original application with one of the new function to the
- -- new arguments.
- change $ MkCore.mkCoreApps (Var newf) newargs
- False ->
- -- Don't change the expression if none of the arguments changed
- return expr
-
- -- If we don't have a body for the function called, leave it unchanged (it
- -- should be a primitive function then).
- Nothing -> return expr
- where
- -- Find the function called and the arguments
- (fexpr, args) = collectArgs expr
- Var f = fexpr
-
- -- Process a single argument and return (args, bndrs, arg), where args are
- -- the arguments to replace the given argument in the original
- -- application, bndrs are the binders to include in the top-level lambda
- -- in the new function body, and arg is the argument to apply to the old
- -- function body.
- doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
- doarg arg = do
- repr <- isRepr arg
- bndrs <- Trans.lift getGlobalBinders
- let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
- if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
- then do
- -- Propagate all complex arguments that are not representable, but not
- -- arguments with free type variables (since those would require types
- -- not known yet, which will always be known eventually).
- -- Find interesting free variables, each of which should be passed to
- -- the new function instead of the original function argument.
- --
- -- Interesting vars are those that are local, but not available from the
- -- top level scope (functions from this module are defined as local, but
- -- they're not local to this function, so we can freely move references
- -- to them into another function).
- let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
- -- Mark the current expression as changed
- setChanged
- return (map Var free_vars, free_vars, arg)
- else do
- -- Representable types will not be propagated, and arguments with free
- -- type variables will be propagated later.
- -- TODO: preserve original naming?
- id <- mkBinderFor arg "param"
- -- Just pass the original argument to the new function, which binds it
- -- to a new id and just pass that new id to the old function body.
- return ([arg], [id], mkReferenceTo id)
--- Leave all other expressions unchanged
-argprop expr = return expr
--- Perform this transform everywhere
-argproptop = everywhere ("argprop", argprop)
-
---------------------------------
--- Function-typed argument extraction
---------------------------------
--- This transform takes any function-typed argument that cannot be propagated
--- (because the function that is applied to it is a builtin function), and
--- puts it in a brand new top level binder. This allows us to for example
--- apply map to a lambda expression This will not conflict with inlinefun,
--- since that only inlines local let bindings, not top level bindings.
-funextract, funextracttop :: Transform
-funextract expr@(App _ _) | is_var fexpr = do
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- -- We don't have a function body for f, so we can perform this transform.
- Nothing -> do
- -- Find the new arguments
- args' <- mapM doarg args
- -- And update the arguments. We use return instead of changed, so the
- -- changed flag doesn't get set if none of the args got changed.
- return $ MkCore.mkCoreApps fexpr args'
- -- We have a function body for f, leave this application to funprop
- Just _ -> return expr
- where
- -- Find the function called and the arguments
- (fexpr, args) = collectArgs expr
- Var f = fexpr
- -- Change any arguments that have a function type, but are not simple yet
- -- (ie, a variable or application). This means to create a new function
- -- for map (\f -> ...) b, but not for map (foo a) b.
- --
- -- We could use is_applicable here instead of is_fun, but I think
- -- arguments to functions could only have forall typing when existential
- -- typing is enabled. Not sure, though.
- doarg arg | not (is_simple arg) && is_fun arg = do
- -- Create a new top level binding that binds the argument. Its body will
- -- be extended with lambda expressions, to take any free variables used
- -- by the argument expression.
- let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
- let body = MkCore.mkCoreLams free_vars arg
- id <- mkBinderFor body "fun"
- Trans.lift $ addGlobalBind id body
- -- Replace the argument with a reference to the new function, applied to
- -- all vars it uses.
- change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
- -- Leave all other arguments untouched
- doarg arg = return arg
-
--- Leave all other expressions unchanged
-funextract expr = return expr
--- Perform this transform everywhere
-funextracttop = everywhere ("funextract", funextract)
-
---------------------------------
--- End of transformations
---------------------------------
-
-
-
-
--- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
-
--- Turns the given bind into VHDL
-normalizeModule ::
- HscTypes.HscEnv
- -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
- -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
- -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
- -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
- -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-
-normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do
- -- Put all the bindings in this module in the tsBindings map
- putA tsBindings (Map.fromList bindings)
- -- (Recursively) normalize each of the requested bindings
- mapM normalizeBind generate_for
- -- Get all initial bindings and the ones we produced
- bindings_map <- getA tsBindings
- let bindings = Map.assocs bindings_map
- normalized_bindings <- getA tsNormalized
- typestate <- getA tsType
- -- But return only the normalized bindings
- return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
-
-normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr =
- -- Don't normalize global variables, these should be either builtin
- -- functions or data constructors.
- Monad.when (Var.isLocalId bndr) $ do
- -- Skip binders that have a polymorphic type, since it's impossible to
- -- create polymorphic hardware.
- if is_poly (Var bndr)
- then
- -- This should really only happen at the top level... TODO: Give
- -- a different error if this happens down in the recursion.
- error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
- else do
- normalized_funcs <- getA tsNormalized
- -- See if this function was normalized already
- if VarSet.elemVarSet bndr normalized_funcs
- then
- -- Yup, don't do it again
- return ()
- else do
- -- Nope, note that it has been and do it.
- modA tsNormalized (flip VarSet.extendVarSet bndr)
- expr_maybe <- getGlobalBind bndr
- case expr_maybe of
- Just expr -> do
- -- Introduce an empty Let at the top level, so there will always be
- -- a let in the expression (none of the transformations will remove
- -- the last let).
- let expr' = Let (Rec []) expr
- -- Normalize this expression
- trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr'
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- -- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr')
- -- Find all vars used with a function type. All of these should be global
- -- binders (i.e., functions used), since any local binders with a function
- -- type should have been inlined already.
- bndrs <- getGlobalBinders
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
- let used_funcs = VarSet.varSetElems used_funcs_set
- -- Process each of the used functions recursively
- mapM normalizeBind used_funcs
- return ()
- -- We don't have a value for this binder. This really shouldn't
- -- happen for local id's...
- Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+++ /dev/null
-{-# LANGUAGE PackageImports #-}
---
--- This module provides functions for program transformations.
---
-module NormalizeTools where
--- Standard modules
-import Debug.Trace
-import qualified List
-import qualified Data.Monoid as Monoid
-import qualified Data.Either as Either
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.State as State
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified "transformers" Control.Monad.Trans as Trans
-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
-
--- GHC API
-import CoreSyn
-import qualified UniqSupply
-import qualified Unique
-import qualified OccName
-import qualified Name
-import qualified Var
-import qualified SrcLoc
-import qualified Type
-import qualified IdInfo
-import qualified CoreUtils
-import qualified CoreSubst
-import qualified VarSet
-import qualified HscTypes
-import Outputable ( showSDoc, ppr, nest )
-
--- Local imports
-import NormalizeTypes
-import Pretty
-import VHDLTypes
-import qualified 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,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
-mkInternalVar str ty = do
- uniq <- mkUnique
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
-
--- Create a new type variable with the given name and kind. A Unique is
--- appended to the given name, to ensure uniqueness (not strictly neccesary,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
-mkTypeVar str kind = do
- uniq <- mkUnique
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkTyVar name kind
-
--- Creates a binder for the given expression with the given name. This
--- works for both value and type level expressions, so it can return a Var or
--- TyVar (which is just an alias for Var).
-mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
-mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
-mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
-
--- Creates a reference to the given variable. This works for both a normal
--- variable as well as a type variable
-mkReferenceTo :: Var.Var -> CoreExpr
-mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
- | otherwise = (Var var)
-
-cloneVar :: Var.Var -> TransformMonad Var.Var
-cloneVar v = do
- uniq <- mkUnique
- -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
- -- contains, but vannillaIdInfo is always correct, since it means "no info").
- return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
-
--- Creates a new function with the same name as the given binder (but with a
--- new unique) and with the given function body. Returns the new binder for
--- this function.
-mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
-mkFunction bndr body = do
- let ty = CoreUtils.exprType body
- id <- cloneVar bndr
- let newid = Var.setVarType id ty
- Trans.lift $ addGlobalBind newid body
- return newid
-
--- Apply the given transformation to all expressions in the given expression,
--- including the expression itself.
-everywhere :: (String, Transform) -> Transform
-everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
-
--- Apply the first transformation, followed by the second transformation, and
--- keep applying both for as long as expression still changes.
-applyboth :: Transform -> (String, Transform) -> Transform
-applyboth first (name, second) expr = do
- -- Apply the first
- expr' <- first expr
- -- Apply the second
- (expr'', changed) <- Writer.listen $ second expr'
- if Monoid.getAny $
--- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
- changed
- then
--- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
--- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
- applyboth first (name, second) $
- expr''
- else
--- trace ("No changes") $
- return expr''
-
--- Apply the given transformation to all direct subexpressions (only), not the
--- expression itself.
-subeverywhere :: Transform -> Transform
-subeverywhere trans (App a b) = do
- a' <- trans a
- b' <- trans b
- return $ App a' b'
-
-subeverywhere trans (Let (NonRec b bexpr) expr) = do
- bexpr' <- trans bexpr
- expr' <- trans expr
- return $ Let (NonRec b bexpr') expr'
-
-subeverywhere trans (Let (Rec binds) expr) = do
- expr' <- trans expr
- binds' <- mapM transbind binds
- return $ Let (Rec binds') expr'
- where
- transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
- transbind (b, e) = do
- e' <- trans e
- return (b, e')
-
-subeverywhere trans (Lam x expr) = do
- expr' <- trans expr
- return $ Lam x expr'
-
-subeverywhere trans (Case scrut b t alts) = do
- scrut' <- trans scrut
- alts' <- mapM transalt alts
- return $ Case scrut' b t alts'
- where
- transalt :: CoreAlt -> TransformMonad CoreAlt
- transalt (con, binders, expr) = do
- expr' <- trans expr
- return (con, binders, expr')
-
-subeverywhere trans (Var x) = return $ Var x
-subeverywhere trans (Lit x) = return $ Lit x
-subeverywhere trans (Type x) = return $ Type x
-
-subeverywhere trans (Cast expr ty) = do
- expr' <- trans expr
- return $ Cast expr' ty
-
-subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
-
--- Apply the given transformation to all expressions, except for direct
--- arguments of an application
-notappargs :: (String, Transform) -> Transform
-notappargs trans = applyboth (subnotappargs trans) trans
-
--- Apply the given transformation to all (direct and indirect) subexpressions
--- (but not the expression itself), except for direct arguments of an
--- application
-subnotappargs :: (String, Transform) -> Transform
-subnotappargs trans (App a b) = do
- a' <- subnotappargs trans a
- b' <- subnotappargs trans b
- return $ App a' b'
-
--- Let subeverywhere handle all other expressions
-subnotappargs trans expr = subeverywhere (notappargs trans) expr
-
--- Runs each of the transforms repeatedly inside the State monad.
-dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
-dotransforms transs expr = do
- (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
- if Monoid.getAny changed then dotransforms transs expr' else return expr'
-
--- Inline all let bindings that satisfy the given condition
-inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
-inlinebind condition expr@(Let (Rec binds) res) = do
- -- Find all bindings that adhere to the condition
- res_eithers <- mapM docond binds
- case Either.partitionEithers res_eithers of
- -- No replaces? No change
- ([], _) -> return expr
- (replace, others) -> do
- -- Substitute the to be replaced binders with their expression
- let newexpr = substitute replace (Let (Rec others) res)
- change newexpr
- where
- docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
- docond b = do
- res <- condition b
- return $ case res of True -> Left b; False -> Right b
-
--- Leave all other expressions unchanged
-inlinebind _ expr = return expr
-
--- Sets the changed flag in the TransformMonad, to signify that some
--- transform has changed the result
-setChanged :: TransformMonad ()
-setChanged = Writer.tell (Monoid.Any True)
-
--- Sets the changed flag and returns the given value.
-change :: a -> TransformMonad a
-change val = do
- setChanged
- return val
-
--- Create a new Unique
-mkUnique :: TransformMonad Unique.Unique
-mkUnique = Trans.lift $ do
- us <- getA tsUniqSupply
- let (us', us'') = UniqSupply.splitUniqSupply us
- putA tsUniqSupply us'
- return $ UniqSupply.uniqFromSupply us''
-
--- Replace each of the binders given with the coresponding expressions in the
--- given expression.
-substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-substitute [] expr = expr
--- Apply one substitution on the expression, but also on any remaining
--- substitutions. This seems to be the only way to handle substitutions like
--- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
--- according to CoreSubst documentation (but it doesn't seem to be a problem).
--- TODO: Find out how this works, exactly.
-substitute ((b, e):subss) expr = substitute subss' expr'
- where
- -- Create the Subst
- subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
- -- Apply this substitution to the main expression
- expr' = CoreSubst.substExpr subs expr
- -- Apply this substitution on all the expressions in the remaining
- -- substitutions
- subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
-
--- Run a given TransformSession. Used mostly to setup the right calls and
--- an initial state.
-runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a
-runTransformSession env uniqSupply session = State.evalState session emptyTransformState
- where
- emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env
- emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState
-
--- Is the given expression representable at runtime, based on the type?
-isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
-isRepr (Type ty) = return False
-isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
-
-is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool
-is_local_var (CoreSyn.Var v) = do
- bndrs <- getGlobalBinders
- return $ not $ v `elem` bndrs
-is_local_var _ = return False
+++ /dev/null
-{-# LANGUAGE TemplateHaskell #-}
-module NormalizeTypes where
-
-
--- Standard modules
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Monoid as Monoid
-import qualified Data.Accessor.Template
-import Data.Accessor
-import qualified Data.Map as Map
-import Debug.Trace
-
--- GHC API
-import CoreSyn
-import qualified UniqSupply
-import qualified VarSet
-import Outputable ( Outputable, showSDoc, ppr )
-
--- Local imports
-import CoreShow
-import Pretty
-import VHDLTypes -- For TypeState
-
-data TransformState = TransformState {
- tsUniqSupply_ :: UniqSupply.UniqSupply
- , tsBindings_ :: Map.Map CoreBndr CoreExpr
- , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
- , tsType_ :: TypeState
-}
-
-$( Data.Accessor.Template.deriveAccessors ''TransformState )
-
--- A session of multiple transformations over multiple expressions
-type TransformSession = (State.State TransformState)
--- Wrap a writer around a TransformSession, to run a single transformation
--- over a single expression and track if the expression was changed.
-type TransformMonad = Writer.WriterT Monoid.Any TransformSession
-
--- | Transforms a CoreExpr and keeps track if it has changed.
-type Transform = CoreExpr -> TransformMonad CoreExpr
-
--- Finds the value of a global binding, if available
-getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr)
-getGlobalBind bndr = do
- bindings <- getA tsBindings
- return $ Map.lookup bndr bindings
-
--- Adds a new global binding with the given value
-addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession ()
-addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr)
-
--- Returns a list of all global binders
-getGlobalBinders :: TransformSession [CoreBndr]
-getGlobalBinders = do
- bindings <- getA tsBindings
- return $ Map.keys bindings
+++ /dev/null
-module Pretty (prettyShow, pprString, pprStringDebug) where
-
-
-import qualified Data.Map as Map
-import qualified Data.Foldable as Foldable
-import qualified List
-
-import qualified CoreSyn
-import qualified Module
-import qualified HscTypes
-import Text.PrettyPrint.HughesPJClass
-import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
-
-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
-
--- | 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) =
- 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)
- modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
-{-
-instance Pretty FuncData where
- pPrint (FuncData flatfunc entity arch) =
- text "Flattened: " $$ nest 15 (ppffunc flatfunc)
- $+$ text "Entity" $$ nest 15 (ppent entity)
- $+$ pparch arch
- where
- ppffunc (Just f) = pPrint f
- ppffunc Nothing = text "Nothing"
- ppent (Just e) = pPrint e
- ppent Nothing = text "Nothing"
- pparch Nothing = text "VHDL architecture not present"
- pparch (Just _) = text "VHDL architecture present"
--}
-
-instance Pretty Entity where
- pPrint (Entity id args res) =
- text "Entity: " $$ nest 10 (pPrint id)
- $+$ text "Args: " $$ nest 10 (pPrint args)
- $+$ text "Result: " $$ nest 10 (pPrint res)
-
-instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
- pPrint (CoreSyn.NonRec b expr) =
- text "NonRec: " $$ nest 10 (prettyBind (b, expr))
- pPrint (CoreSyn.Rec binds) =
- text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
-
-instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
- pPrint = text . show
-
-instance Pretty AST.VHDLId where
- pPrint id = Ppr.ppr id
-
-instance Pretty AST.VHDLName where
- pPrint name = Ppr.ppr name
-
-prettyBind :: (Show b, Show e) => (b, e) -> Doc
-prettyBind (b, expr) =
- text b' <> text " = " <> text expr'
- where
- b' = show b
- expr' = show expr
-
-instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
- pPrint =
- vcat . map ppentry . Map.toList
- where
- ppentry (k, v) =
- pPrint k <> text " : " $$ nest 15 (pPrint v)
-
--- Convenience method for turning an Outputable into a string
-pprString :: (Outputable x) => x -> String
-pprString = showSDoc . ppr
-
-pprStringDebug :: (Outputable x) => x -> String
-pprStringDebug = showSDocDebug . ppr
+++ /dev/null
-module Translator where
-import qualified Directory
-import qualified System.FilePath as FilePath
-import qualified List
-import Debug.Trace
-import qualified Control.Arrow as Arrow
-import GHC hiding (loadModule, sigName)
-import CoreSyn
-import qualified CoreUtils
-import qualified Var
-import qualified Type
-import qualified TyCon
-import qualified DataCon
-import qualified HscMain
-import qualified SrcLoc
-import qualified FastString
-import qualified Maybe
-import qualified Module
-import qualified Data.Foldable as Foldable
-import qualified Control.Monad.Trans.State as State
-import Name
-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Generics
-import NameEnv ( lookupNameEnv )
-import qualified HscTypes
-import HscTypes ( cm_binds, cm_types )
-import MonadUtils ( liftIO )
-import Outputable ( showSDoc, ppr, showSDocDebug )
-import GHC.Paths ( libdir )
-import DynFlags ( defaultDynFlags )
-import qualified UniqSupply
-import List ( find )
-import qualified List
-import qualified Monad
-
--- The following modules come from the ForSyDe project. They are really
--- internal modules, so ForSyDe.cabal has to be modified prior to installing
--- ForSyDe to get access to these modules.
-import qualified Language.VHDL.AST as AST
-import qualified Language.VHDL.FileIO
-import qualified Language.VHDL.Ppr as Ppr
--- This is needed for rendering the pretty printed VHDL
-import Text.PrettyPrint.HughesPJ (render)
-
-import TranslatorTypes
-import HsValueMap
-import Pretty
-import Normalize
--- import Flatten
--- import FlattenTypes
-import VHDLTypes
-import qualified VHDL
-
-makeVHDL :: String -> String -> Bool -> IO ()
-makeVHDL filename name stateful = do
- -- Load the module
- (core, env) <- loadModule filename
- -- Translate to VHDL
- vhdl <- moduleToVHDL env core [(name, stateful)]
- -- Write VHDL to file
- let dir = "./vhdl/" ++ name ++ "/"
- prepareDir dir
- mapM (writeVHDL dir) vhdl
- return ()
-
-listBindings :: String -> IO [()]
-listBindings filename = do
- (core, env) <- loadModule filename
- let binds = CoreSyn.flattenBinds $ cm_binds core
- mapM (listBinding) binds
-
-listBinding :: (CoreBndr, CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b
- putStr "\nExpression: \n"
- putStr $ prettyShow e
- putStr "\n\n"
- putStr $ showSDoc $ ppr e
- putStr "\n\n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType e
- putStr "\n\n"
-
--- | Show the core structure of the given binds in the given file.
-listBind :: String -> String -> IO ()
-listBind filename name = do
- (core, env) <- loadModule filename
- let [(b, expr)] = findBinds core [name]
- putStr "\n"
- putStr $ prettyShow expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
- putStr "\n\n"
-
--- | Translate the binds with the given names from the given core module to
--- VHDL. The Bool in the tuple makes the function stateful (True) or
--- stateless (False).
-moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env core list = do
- let (names, statefuls) = unzip list
- let binds = map fst $ findBinds core names
- -- Generate a UniqSupply
- -- Running
- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
- -- on the compiler dir of ghc suggests that 'z' is not used to generate a
- -- unique supply anywhere.
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- -- Turn bind into VHDL
- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
- let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
- let vhdl = VHDL.createDesignFiles typestate normalized_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
- return vhdl
- where
-
--- | Prepares the directory for writing VHDL files. This means creating the
--- dir if it does not exist and removing all existing .vhdl files from it.
-prepareDir :: String -> IO()
-prepareDir dir = do
- -- Create the dir if needed
- exists <- Directory.doesDirectoryExist dir
- Monad.unless exists $ Directory.createDirectory dir
- -- Find all .vhdl files in the directory
- files <- Directory.getDirectoryContents dir
- let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
- -- Prepend the dirname to the filenames
- let abs_to_remove = map (FilePath.combine dir) to_remove
- -- Remove the files
- mapM_ Directory.removeFile abs_to_remove
-
--- | Write the given design file to a file with the given name inside the
--- given dir
-writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
-writeVHDL dir (name, vhdl) = do
- -- Find the filename
- let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
- -- Write the file
- Language.VHDL.FileIO.writeDesignFile vhdl fname
-
--- | Loads the given file and turns it into a core module.
-loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
-loadModule filename =
- defaultErrorHandler defaultDynFlags $ do
- runGhc (Just libdir) $ do
- dflags <- getSessionDynFlags
- setSessionDynFlags dflags
- --target <- guessTarget "adder.hs" Nothing
- --liftIO (print (showSDoc (ppr (target))))
- --liftIO $ printTarget target
- --setTargets [target]
- --load LoadAllTargets
- --core <- GHC.compileToCoreSimplified "Adders.hs"
- core <- GHC.compileToCoreModule filename
- env <- GHC.getSession
- return (core, env)
-
--- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
-findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
-
--- | Extract a named bind from the given list of binds
-findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
-findBind binds lookfor =
- -- This ignores Recs and compares the name of the bind with lookfor,
- -- disregarding any namespaces in OccName and extra attributes in Name and
- -- Var.
- find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
-
--- | Flattens the given bind into the given signature and adds it to the
--- session. Then (recursively) finds any functions it uses and does the same
--- with them.
--- flattenBind ::
--- HsFunction -- The signature to flatten into
--- -> (CoreBndr, CoreExpr) -- The bind to flatten
--- -> TranslatorState ()
---
--- flattenBind hsfunc bind@(var, expr) = do
--- -- Flatten the function
--- let flatfunc = flattenFunction hsfunc bind
--- -- Propagate state variables
--- let flatfunc' = propagateState hsfunc flatfunc
--- -- Store the flat function in the session
--- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
--- -- Flatten any functions used
--- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
--- mapM_ resolvFunc used_hsfuncs
-
--- | Decide which incoming state variables will become state in the
--- given function, and which will be propagate to other applied
--- functions.
--- propagateState ::
--- HsFunction
--- -> FlatFunction
--- -> FlatFunction
---
--- propagateState hsfunc flatfunc =
--- flatfunc {flat_defs = apps', flat_sigs = sigs'}
--- where
--- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
--- states' = zip olds news
--- -- Find all signals used by all sigdefs
--- uses = concatMap sigDefUses (flat_defs flatfunc)
--- -- Find all signals that are used more than once (is there a
--- -- prettier way to do this?)
--- multiple_uses = uses List.\\ (List.nub uses)
--- -- Find the states whose "old state" signal is used only once
--- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
--- -- See if these single use states can be propagated
--- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
--- substate_sigs = concat substate_sigss
--- -- Mark any propagated state signals as SigSubState
--- sigs' = map
--- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
--- (flat_sigs flatfunc)
-
--- | Propagate the state into a single function application.
--- propagateState' ::
--- [(SignalId, SignalId)]
--- -- ^ TODO
--- -> SigDef -- ^ The SigDef to process.
--- -> ([SignalId], SigDef)
--- -- ^ Any signal ids that should become substates,
--- -- and the resulting application.
---
--- propagateState' states def =
--- if (is_FApp def) then
--- (our_old ++ our_new, def {appFunc = hsfunc'})
--- else
--- ([], def)
--- where
--- hsfunc = appFunc def
--- args = appArgs def
--- res = appRes def
--- our_states = filter our_state states
--- -- A state signal belongs in this function if the old state is
--- -- passed in, and the new state returned
--- our_state (old, new) =
--- any (old `Foldable.elem`) args
--- && new `Foldable.elem` res
--- (our_old, our_new) = unzip our_states
--- -- Mark the result
--- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
--- res' = fmap (mark_state (zip our_new [0..])) zipped_res
--- -- Mark the args
--- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
--- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
--- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
---
--- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
--- mark_state states (id, use) =
--- case lookup id states of
--- Nothing -> use
--- Just state_id -> State state_id
-
--- | Returns pairs of signals that should be mapped to state in this function.
--- getStateSignals ::
--- HsFunction -- | The function to look at
--- -> FlatFunction -- | The function to look at
--- -> [(SignalId, SignalId)]
--- -- | TODO The state signals. The first is the state number, the second the
--- -- signal to assign the current state to, the last is the signal
--- -- that holds the new state.
---
--- getStateSignals hsfunc flatfunc =
--- [(old_id, new_id)
--- | (old_num, old_id) <- args
--- , (new_num, new_id) <- res
--- , old_num == new_num]
--- where
--- sigs = flat_sigs flatfunc
--- -- Translate args and res to lists of (statenum, sigid)
--- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
--- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
-
--- | Find the given function, flatten it and add it to the session. Then
--- (recursively) do the same for any functions used.
--- resolvFunc ::
--- HsFunction -- | The function to look for
--- -> TranslatorState ()
---
--- resolvFunc hsfunc = do
--- flatfuncmap <- getA tsFlatFuncs
--- -- Don't do anything if there is already a flat function for this hsfunc or
--- -- when it is a builtin function.
--- Monad.unless (Map.member hsfunc flatfuncmap) $ do
--- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
--- -- New function, resolve it
--- core <- getA tsCoreModule
--- -- Find the named function
--- let name = (hsFuncName hsfunc)
--- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
--- case bind of
--- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
--- Just b -> flattenBind hsfunc b
-
--- | Translate a top level function declaration to a HsFunction. i.e., which
--- interface will be provided by this function. This function essentially
--- defines the "calling convention" for hardware models.
--- mkHsFunction ::
--- Var.Var -- ^ The function defined
--- -> Type -- ^ The function type (including arguments!)
--- -> Bool -- ^ Is this a stateful function?
--- -> HsFunction -- ^ The resulting HsFunction
---
--- mkHsFunction f ty stateful=
--- HsFunction hsname hsargs hsres
--- where
--- hsname = getOccString f
--- (arg_tys, res_ty) = Type.splitFunTys ty
--- (hsargs, hsres) =
--- if stateful
--- then
--- let
--- -- The last argument must be state
--- state_ty = last arg_tys
--- state = useAsState (mkHsValueMap state_ty)
--- -- All but the last argument are inports
--- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
--- hsargs = inports ++ [state]
--- hsres = case splitTupleType res_ty of
--- -- Result type must be a two tuple (state, ports)
--- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
--- then
--- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
--- else
--- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
--- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
--- in
--- (hsargs, hsres)
--- else
--- -- Just use everything as a port
--- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-
--- | Adds signal names to the given FlatFunction
--- nameFlatFunction ::
--- FlatFunction
--- -> FlatFunction
---
--- nameFlatFunction flatfunc =
--- -- Name the signals
--- let
--- s = flat_sigs flatfunc
--- s' = map nameSignal s in
--- flatfunc { flat_sigs = s' }
--- where
--- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
--- nameSignal (id, info) =
--- let hints = nameHints info in
--- let parts = ("sig" : hints) ++ [show id] in
--- let name = concat $ List.intersperse "_" parts in
--- (id, info {sigName = Just name})
---
--- -- | Splits a tuple type into a list of element types, or Nothing if the type
--- -- is not a tuple type.
--- splitTupleType ::
--- Type -- ^ The type to split
--- -> Maybe [Type] -- ^ The tuples element types
---
--- splitTupleType ty =
--- case Type.splitTyConApp_maybe ty of
--- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
--- then
--- Just args
--- else
--- Nothing
--- Nothing -> Nothing
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
---
--- Simple module providing some types used by Translator. These are in a
--- separate module to prevent circular dependencies in Pretty for example.
---
-{-# LANGUAGE TemplateHaskell #-}
-module TranslatorTypes where
-
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Map as Map
-import qualified Data.Accessor.Template
-import Data.Accessor
-
-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
-
-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
-}
-
--- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TranslatorSession )
-
-type TranslatorState = State.State TranslatorSession
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
---
--- Functions to generate VHDL from FlatFunctions
---
-module VHDL where
-
--- Standard modules
-import qualified Data.List as List
-import qualified Data.Map as Map
-import qualified Maybe
-import qualified Control.Monad as Monad
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Monoid as Monoid
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
-import Debug.Trace
-
--- ForSyDe
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import CoreSyn
---import qualified Type
-import qualified Name
-import qualified Var
-import qualified Id
-import qualified IdInfo
-import qualified TyCon
-import qualified DataCon
---import qualified CoreSubst
-import qualified CoreUtils
-import Outputable ( showSDoc, ppr )
-
--- Local imports
-import VHDLTypes
-import VHDLTools
-import Pretty
-import CoreTools
-import Constants
-import Generate
-
-createDesignFiles ::
- TypeState
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> [(AST.VHDLId, AST.DesignFile)]
-
-createDesignFiles init_typestate binds =
- (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
- map (Arrow.second $ AST.DesignFile full_context) units
-
- where
- init_session = VHDLState init_typestate Map.empty
- (units, final_session) =
- State.runState (createLibraryUnits binds) init_session
- tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
- ty_decls = final_session ^. vsType ^. vsTypeDecls
- tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
- tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
- tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
- ieee_context = [
- AST.Library $ mkVHDLBasicId "IEEE",
- mkUseAll ["IEEE", "std_logic_1164"],
- mkUseAll ["IEEE", "numeric_std"]
- ]
- full_context =
- mkUseAll ["work", "types"]
- : (mkUseAll ["work"]
- : ieee_context)
- type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
- type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
- subProgSpecs = map subProgSpec tyfun_decls
- subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
-
--- Create a use foo.bar.all statement. Takes a list of components in the used
--- name. Must contain at least two components
-mkUseAll :: [String] -> AST.ContextItem
-mkUseAll ss =
- AST.Use $ from AST.:.: AST.All
- where
- base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
- from = foldl select base_prefix (tail ss)
- select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
-
-createLibraryUnits ::
- [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
-
-createLibraryUnits binds = do
- entities <- Monad.mapM createEntity binds
- archs <- Monad.mapM createArchitecture binds
- return $ zipWith
- (\ent arch ->
- let AST.EntityDec id _ = ent in
- (id, [AST.LUEntity ent, AST.LUArch arch])
- )
- entities archs
-
--- | Create an entity for a given function
-createEntity ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
- -> VHDLSession AST.EntityDec -- | The resulting entity
-
-createEntity (fname, expr) = do
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- args' <- Monad.mapM mkMap args
- -- There must be a let at top level
- let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
- res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
- let ent_decl' = createEntityAST vhdl_id args' res'
- let AST.EntityDec entity_id _ = ent_decl'
- let signature = Entity entity_id args' res'
- modA vsSignatures (Map.insert fname signature)
- return ent_decl'
- where
- mkMap ::
- --[(SignalId, SignalInfo)]
- CoreSyn.CoreBndr
- -> VHDLSession Port
- -- We only need the vsTypes element from the state
- mkMap = (\bndr ->
- let
- --info = Maybe.fromMaybe
- -- (error $ "Signal not found in the name map? This should not happen!")
- -- (lookup id sigmap)
- -- Assume the bndr has a valid VHDL id already
- id = varToVHDLId bndr
- ty = Var.varType bndr
- error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
- in do
- type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
- return (id, type_mark)
- )
-
- -- | Create the VHDL AST for an entity
-createEntityAST ::
- AST.VHDLId -- | The name of the function
- -> [Port] -- | The entity's arguments
- -> Port -- | The entity's result
- -> AST.EntityDec -- | The entity with the ent_decl filled in as well
-
-createEntityAST vhdl_id args res =
- AST.EntityDec vhdl_id ports
- where
- -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
- ports = map (mkIfaceSigDec AST.In) args
- ++ [mkIfaceSigDec AST.Out res]
- ++ [clk_port]
- -- Add a clk port if we have state
- clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
-
--- | Create a port declaration
-mkIfaceSigDec ::
- AST.Mode -- | The mode for the port (In / Out)
- -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
- -> AST.IfaceSigDec -- | The resulting port declaration
-
-mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
-
-{-
--- | Generate a VHDL entity name for the given hsfunc
-mkEntityId hsfunc =
- -- TODO: This doesn't work for functions with multiple signatures!
- -- Use a Basic Id, since using extended id's for entities throws off
- -- precision and causes problems when generating filenames.
- mkVHDLBasicId $ hsFuncName hsfunc
--}
-
--- | Create an architecture for a given function
-createArchitecture ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLSession AST.ArchBody -- ^ The architecture for this function
-
-createArchitecture (fname, expr) = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
- (Map.lookup fname signaturemap)
- let entity_id = ent_id signature
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
-
- -- Create signal declarations for all binders in the let expression, except
- -- for the output port (that will already have an output port declared in
- -- the entity).
- sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
- let sig_decs = Maybe.catMaybes $ sig_dec_maybes
-
- statementss <- Monad.mapM mkConcSm binds
- let statements = concat statementss
- return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
- where
- procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
- procs' = map AST.CSPSm procs
- -- mkSigDec only uses vsTypes from the state
- mkSigDec' = mkSigDec
-
-{-
--- | Looks up all pairs of old state, new state signals, together with
--- the state id they represent.
-makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
-makeStatePairs flatfunc =
- [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
- | old_info <- map snd (flat_sigs flatfunc)
- , new_info <- map snd (flat_sigs flatfunc)
- -- old_info must be an old state (and, because of the next equality,
- -- new_info must be a new state).
- , Maybe.isJust $ oldStateId $ sigUse old_info
- -- And the state numbers must match
- , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
-
- -- Replace the second tuple element with the corresponding SignalInfo
- --args_states = map (Arrow.second $ signalInfo sigs) args
-mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
-mkStateProcSm (num, old, new) =
- AST.ProcSm label [clk] [statement]
- where
- label = mkVHDLExtId $ "state_" ++ (show num)
- clk = mkVHDLExtId "clk"
- rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
- assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
- statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-
--- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
--- is not named.
-getSignalId :: SignalInfo -> AST.VHDLId
-getSignalId info =
- mkVHDLExtId $ Maybe.fromMaybe
- (error $ "Unnamed signal? This should not happen!")
- (sigName info)
--}
-
-mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
-mkSigDec bndr =
- if True then do --isInternalSigUse use || isStateSigUse use then do
- let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
- type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
- return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
- else
- return Nothing
-
--- | Transforms a core binding into a VHDL concurrent statement
-mkConcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
-
-
--- Ignore Cast expressions, they should not longer have any meaning as long as
--- the type works out.
-mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
-
--- Simple a = b assignments are just like applications, but without arguments.
--- We can't just generate an unconditional assignment here, since b might be a
--- top level binding (e.g., a function with no arguments).
-mkConcSm (bndr, Var v) = do
- genApplication (Left bndr) v []
-
-mkConcSm (bndr, app@(CoreSyn.App _ _))= do
- let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- let valargs = get_val_args (Var.varType f) args
- genApplication (Left bndr) f (map Left valargs)
-
--- A single alt case must be a selector. This means thee scrutinee is a simple
--- variable, the alternative is a dataalt with a single non-wild binder that
--- is also returned.
-mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
- case alt of
- (DataAlt dc, bndrs, (Var sel_bndr)) -> do
- case List.elemIndex sel_bndr bndrs of
- Just i -> do
- labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
- let label = labels!!i
- let sel_name = mkSelectedName (varToVHDLName scrut) label
- let sel_expr = AST.PrimName sel_name
- return [mkUncondAssign (Left bndr) sel_expr]
- Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
- _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
--- Multiple case alt are be conditional assignments and have only wild
--- binders in the alts and only variables in the case values and a variable
--- for a scrutinee. We check the constructor of the second alt, since the
--- first is the default case, if there is any.
-mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
- scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
- let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
- true_expr <- MonadState.lift vsType $ varToVHDLExpr true
- false_expr <- MonadState.lift vsType $ varToVHDLExpr false
- return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
-mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
+++ /dev/null
-module VHDLTools where
-
--- Standard modules
-import qualified Maybe
-import qualified Data.Either as Either
-import qualified Data.List as List
-import qualified Data.Map as Map
-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 Debug.Trace
-
--- ForSyDe
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import CoreSyn
-import qualified Name
-import qualified OccName
-import qualified Var
-import qualified Id
-import qualified IdInfo
-import qualified TyCon
-import qualified Type
-import qualified DataCon
-import qualified CoreSubst
-
--- Local imports
-import VHDLTypes
-import CoreTools
-import Pretty
-import Constants
-
------------------------------------------------------------------------------
--- Functions to generate concurrent statements
------------------------------------------------------------------------------
-
--- Create an unconditional assignment statement
-mkUncondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The expression to assign
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkUncondAssign dst expr = mkAssign dst Nothing expr
-
--- Create a conditional assignment statement
-mkCondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The condition
- -> AST.Expr -- ^ The value when true
- -> AST.Expr -- ^ The value when false
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
-
--- Create a conditional or unconditional assignment statement
-mkAssign ::
- Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
- Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
- -- and the value to assign when true.
- AST.Expr -> -- ^ The value to assign when false or no condition
- AST.ConcSm -- ^ The resulting concurrent statement
-mkAssign dst cond false_expr =
- let
- -- I'm not 100% how this assignment AST works, but this gets us what we
- -- want...
- whenelse = case cond of
- Just (cond_expr, true_expr) ->
- let
- true_wform = AST.Wform [AST.WformElem true_expr Nothing]
- in
- [AST.WhenElse true_wform cond_expr]
- Nothing -> []
- false_wform = AST.Wform [AST.WformElem false_expr Nothing]
- dst_name = case dst of
- Left bndr -> AST.NSimple (varToVHDLId bndr)
- Right name -> name
- assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
- in
- AST.CSSASm assign
-
-mkAssocElems ::
- [AST.Expr] -- | The argument that are applied to function
- -> AST.VHDLName -- | The binder in which to store the result
- -> Entity -- | The entity to map against.
- -> [AST.AssocElem] -- | The resulting port maps
-mkAssocElems args res entity =
- -- Create the actual AssocElems
- zipWith mkAssocElem ports sigs
- where
- -- Turn the ports and signals from a map into a flat list. This works,
- -- since the maps must have an identical form by definition. TODO: Check
- -- the similar form?
- arg_ports = ent_args entity
- res_port = ent_res entity
- -- Extract the id part from the (id, type) tuple
- ports = map fst (res_port : arg_ports)
- -- Translate signal numbers into names
- sigs = (vhdlNameToVHDLExpr res : args)
-
--- | Create an VHDL port -> signal association
-mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
-mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
-
--- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
-mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
- (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
-
-mkComponentInst ::
- String -- ^ The portmap label
- -> AST.VHDLId -- ^ The entity name
- -> [AST.AssocElem] -- ^ The port assignments
- -> AST.ConcSm
-mkComponentInst label entity_id portassigns = AST.CSISm compins
- where
- -- We always have a clock port, so no need to map it anywhere but here
- clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
-
------------------------------------------------------------------------------
--- Functions to generate VHDL Exprs
------------------------------------------------------------------------------
-
-varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
-varToVHDLExpr var = do
- case Id.isDataConWorkId_maybe var of
- Just dc -> return $ dataconToVHDLExpr dc
- -- This is a dataconstructor.
- -- Not a datacon, just another signal. Perhaps we should check for
- -- local/global here as well?
- -- Sadly so.. tfp decimals are types, not data constructors, but instances
- -- should still be translated to integer literals. It is probebly not the
- -- best solution to translate them here.
- -- FIXME: Find a better solution for translating instances of tfp integers
- Nothing -> do
- let ty = Var.varType var
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) ->
- case Name.getOccString (TyCon.tyConName tycon) of
- "Dec" -> do
- len <- tfp_to_int ty
- return $ AST.PrimLit $ (show len)
- otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
-
--- Turn a VHDLName into an AST expression
-vhdlNameToVHDLExpr = AST.PrimName
-
--- Turn a VHDL Id into an AST expression
-idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
-
--- Turn a Core expression into an AST expression
-exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
-
--- Turn a alternative constructor into an AST expression. For
--- dataconstructors, this is only the constructor itself, not any arguments it
--- has. Should not be called with a DEFAULT constructor.
-altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
-altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
-
-altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
-
--- Turn a datacon (without arguments!) into a VHDL expression.
-dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
-dataconToVHDLExpr dc = AST.PrimLit lit
- where
- tycon = DataCon.dataConTyCon dc
- tyname = TyCon.tyConName tycon
- dcname = DataCon.dataConName dc
- lit = case Name.getOccString tyname of
- -- TODO: Do something more robust than string matching
- "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
- "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
-
------------------------------------------------------------------------------
--- Functions dealing with names, variables and ids
------------------------------------------------------------------------------
-
--- Creates a VHDL Id from a binder
-varToVHDLId ::
- CoreSyn.CoreBndr
- -> AST.VHDLId
-varToVHDLId = mkVHDLExtId . varToString
-
--- Creates a VHDL Name from a binder
-varToVHDLName ::
- CoreSyn.CoreBndr
- -> AST.VHDLName
-varToVHDLName = AST.NSimple . varToVHDLId
-
--- Extracts the binder name as a String
-varToString ::
- CoreSyn.CoreBndr
- -> String
-varToString = OccName.occNameString . Name.nameOccName . Var.varName
-
--- Get the string version a Var's unique
-varToStringUniq :: Var.Var -> String
-varToStringUniq = show . Var.varUnique
-
--- Extracts the string version of the name
-nameToString :: Name.Name -> String
-nameToString = OccName.occNameString . Name.nameOccName
-
--- Shortcut for Basic VHDL Ids.
--- Can only contain alphanumerics and underscores. The supplied string must be
--- a valid basic id, otherwise an error value is returned. This function is
--- not meant to be passed identifiers from a source file, use mkVHDLExtId for
--- that.
-mkVHDLBasicId :: String -> AST.VHDLId
-mkVHDLBasicId s =
- AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
- where
- -- Strip invalid characters.
- strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
- -- Strip leading numbers and underscores
- strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
- -- Strip multiple adjacent underscores
- strip_multiscore = concat . map (\cs ->
- case cs of
- ('_':_) -> "_"
- _ -> cs
- ) . List.group
-
--- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
--- different characters than basic ids, but can never be used to refer to
--- basic ids.
--- Use extended Ids for any values that are taken from the source file.
-mkVHDLExtId :: String -> AST.VHDLId
-mkVHDLExtId s =
- AST.unsafeVHDLExtId $ strip_invalid s
- where
- -- Allowed characters, taken from ForSyde's mkVHDLExtId
- allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
- strip_invalid = filter (`elem` allowed)
-
--- Create a record field selector that selects the given label from the record
--- stored in the given binder.
-mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
-mkSelectedName name label =
- AST.NSelected $ name AST.:.: (AST.SSimple label)
-
--- Create an indexed name that selects a given element from a vector.
-mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
--- Special case for already indexed names. Just add an index
-mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
- AST.NIndexed (AST.IndexedName name (indexes++[index]))
--- General case for other names
-mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
-
------------------------------------------------------------------------------
--- Functions dealing with VHDL types
------------------------------------------------------------------------------
-
--- | Maps the string name (OccName) of a type to the corresponding VHDL type,
--- for a few builtin types.
-builtin_types =
- Map.fromList [
- ("Bit", std_logicTM),
- ("Bool", booleanTM), -- TysWiredIn.boolTy
- ("Dec", integerTM)
- ]
-
--- Translate a Haskell type to a VHDL type, generating a new type if needed.
--- Returns an error value, using the given message, when no type could be
--- created.
-vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
-vhdl_ty msg ty = do
- tm_either <- vhdl_ty_either ty
- case tm_either of
- Right tm -> return tm
- Left err -> error $ msg ++ "\n" ++ err
-
--- Translate a Haskell type to a VHDL type, generating a new type if needed.
--- Returns either an error message or the resulting type.
-vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
-vhdl_ty_either ty = do
- typemap <- getA vsTypes
- htype_either <- mkHType ty
- case htype_either of
- -- No errors
- Right htype -> do
- let builtin_ty = do -- See if this is a tycon and lookup its name
- (tycon, args) <- Type.splitTyConApp_maybe ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- Map.lookup name builtin_types
- -- If not a builtin type, try the custom types
- let existing_ty = (fmap fst) $ Map.lookup htype typemap
- case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
- -- Found a type, return it
- Just t -> return (Right t)
- -- No type yet, try to construct it
- Nothing -> do
- newty_maybe <- (construct_vhdl_ty ty)
- case newty_maybe of
- Right (ty_id, ty_def) -> do
- -- TODO: Check name uniqueness
- modA vsTypes (Map.insert htype (ty_id, ty_def))
- modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
- return (Right ty_id)
- Left err -> return $ Left $
- "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
- ++ err
- -- Error when constructing htype
- Left err -> return $ Left err
-
--- Construct a new VHDL type for the given Haskell type. Returns an error
--- message or the resulting typemark and typedef.
-construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty ty = do
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> do
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "TFVec" -> mk_vector_ty ty
- "SizedWord" -> mk_unsigned_ty ty
- "SizedInt" -> mk_signed_ty ty
- "RangedWord" -> do
- bound <- tfp_to_int (ranged_word_bound_ty ty)
- mk_natural_ty 0 bound
- -- Create a custom type from this tycon
- otherwise -> mk_tycon_ty tycon args
- Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
-
--- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
- case TyCon.tyConDataCons tycon of
- -- Not an algebraic type
- [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
- [dc] -> do
- let arg_tys = DataCon.dataConRepArgTys dc
- -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
- -- violation? Or does it only mean not to apply it again to the same
- -- subject?
- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- elem_tys_either <- mapM vhdl_ty_either real_arg_tys
- case Either.partitionEithers elem_tys_either of
- -- No errors in element types
- ([], elem_tys) -> do
- let elems = zipWith AST.ElementDec recordlabels elem_tys
- -- For a single construct datatype, build a record with one field for
- -- each argument.
- -- TODO: Add argument type ids to this, to ensure uniqueness
- -- TODO: Special handling for tuples?
- let elem_names = concat $ map prettyShow elem_tys
- let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
- let ty_def = AST.TDR $ AST.RecordTypeDef elems
- return $ Right (ty_id, Left ty_def)
- -- There were errors in element types
- (errors, _) -> return $ Left $
- "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
- ++ (concat errors)
- dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
- where
- -- Create a subst that instantiates all types passed to the tycon
- -- TODO: I'm not 100% sure that this is the right way to do this. It seems
- -- to work so far, though..
- tyvars = TyCon.tyConTyVars tycon
- subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
- -- Generate a bunch of labels for fields of a record
- recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
-
--- | Create a VHDL vector type
-mk_vector_ty ::
- Type.Type -- ^ The Haskell type of the Vector
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
- -- ^ An error message or The typemark created.
-
-mk_vector_ty ty = do
- types_map <- getA vsTypes
- env <- getA vsHscEnv
- let (nvec_l, nvec_el) = Type.splitAppTy ty
- let (nvec, leng) = Type.splitAppTy nvec_l
- let vec_ty = Type.mkAppTy nvec nvec_el
- len <- tfp_to_int (tfvec_len_ty ty)
- let el_ty = tfvec_elem ty
- el_ty_tm_either <- vhdl_ty_either el_ty
- case el_ty_tm_either of
- -- Could create element type
- Right el_ty_tm -> do
- let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
- case existing_elem_ty of
- Just t -> do
- let ty_def = AST.SubtypeIn t (Just range)
- return (Right (ty_id, Right ty_def))
- Nothing -> do
- let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
- let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
- modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
- modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
- let ty_def = AST.SubtypeIn vec_id (Just range)
- return (Right (ty_id, Right ty_def))
- -- Could not create element type
- Left err -> return $ Left $
- "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
- ++ err
-
-mk_natural_ty ::
- Int -- ^ The minimum bound (> 0)
- -> Int -- ^ The maximum bound (> minimum bound)
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
- -- ^ An error message or The typemark created.
-mk_natural_ty min_bound max_bound = do
- let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
- let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
- let ty_def = AST.SubtypeIn naturalTM (Just range)
- return (Right (ty_id, Right ty_def))
-
-mk_unsigned_ty ::
- Type.Type -- ^ Haskell type of the unsigned integer
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_unsigned_ty ty = do
- size <- tfp_to_int (sized_word_len_ty ty)
- let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
- let ty_def = AST.SubtypeIn unsignedTM (Just range)
- return (Right (ty_id, Right ty_def))
-
-mk_signed_ty ::
- Type.Type -- ^ Haskell type of the signed integer
- -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_signed_ty ty = do
- size <- tfp_to_int (sized_int_len_ty ty)
- let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
- let ty_def = AST.SubtypeIn signedTM (Just range)
- return (Right (ty_id, Right ty_def))
-
--- Finds the field labels for VHDL type generated for the given Core type,
--- which must result in a record type.
-getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
-getFieldLabels ty = do
- -- Ensure that the type is generated (but throw away it's VHDLId)
- let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
- vhdl_ty error_msg ty
- -- Get the types map, lookup and unpack the VHDL TypeDef
- types <- getA vsTypes
- -- Assume the type for which we want labels is really translatable
- Right htype <- mkHType ty
- case Map.lookup htype types of
- Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
- _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
-
-mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
-mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
-mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
-
-mkHType :: Type.Type -> TypeSession (Either String HType)
-mkHType ty = do
- -- FIXME: Do we really need to do this here again?
- let builtin_ty = do -- See if this is a tycon and lookup its name
- (tycon, args) <- Type.splitTyConApp_maybe ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- Map.lookup name builtin_types
- case builtin_ty of
- Just typ ->
- return $ Right $ BuiltinType $ prettyShow typ
- Nothing ->
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> do
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "TFVec" -> do
- let el_ty = tfvec_elem ty
- elem_htype_either <- mkHType el_ty
- case elem_htype_either of
- -- Could create element type
- Right elem_htype -> do
- len <- tfp_to_int (tfvec_len_ty ty)
- return $ Right $ VecType len elem_htype
- -- Could not create element type
- Left err -> return $ Left $
- "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
- ++ err
- "SizedWord" -> do
- len <- tfp_to_int (sized_word_len_ty ty)
- return $ Right $ SizedWType len
- "SizedInt" -> do
- len <- tfp_to_int (sized_word_len_ty ty)
- return $ Right $ SizedIType len
- "RangedWord" -> do
- bound <- tfp_to_int (ranged_word_bound_ty ty)
- return $ Right $ RangedWType bound
- otherwise -> do
- mkTyConHType tycon args
- Nothing -> return $ Right $ StdType $ OrdType ty
-
--- FIXME: Do we really need to do this here again?
-mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
-mkTyConHType tycon args =
- case TyCon.tyConDataCons tycon of
- -- Not an algebraic type
- [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
- [dc] -> do
- let arg_tys = DataCon.dataConRepArgTys dc
- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- elem_htys_either <- mapM mkHType real_arg_tys
- case Either.partitionEithers elem_htys_either of
- -- No errors in element types
- ([], elem_htys) -> do
- return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
- -- There were errors in element types
- (errors, _) -> return $ Left $
- "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
- ++ (concat errors)
- dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
- where
- tyvars = TyCon.tyConTyVars tycon
- subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
-
--- Is the given type representable at runtime?
-isReprType :: Type.Type -> TypeSession Bool
-isReprType ty = do
- ty_either <- vhdl_ty_either ty
- return $ case ty_either of
- Left _ -> False
- Right _ -> True
-
-tfp_to_int :: Type.Type -> TypeSession Int
-tfp_to_int ty = do
- lens <- getA vsTfpInts
- hscenv <- getA vsHscEnv
- let norm_ty = normalise_tfp_int hscenv ty
- let existing_len = Map.lookup (OrdType norm_ty) lens
- case existing_len of
- Just len -> return len
- Nothing -> do
- let new_len = eval_tfp_int hscenv ty
- modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
- return new_len
\ No newline at end of file
+++ /dev/null
---
--- Some types used by the VHDL module.
---
-{-# LANGUAGE TemplateHaskell #-}
-module VHDLTypes where
-
--- Standard imports
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Map as Map
-import Data.Accessor
-import qualified Data.Accessor.Template
-
--- GHC API imports
-import qualified Type
-import qualified CoreSyn
-import qualified HscTypes
-
--- ForSyDe imports
-import qualified Language.VHDL.AST as AST
-
--- Local imports
-
--- A description of a port of an entity
-type Port = (AST.VHDLId, AST.TypeMark)
-
--- A description of a VHDL entity. Contains both the entity itself as well as
--- info on how to map a haskell value (argument / result) on to the entity's
--- ports.
-data Entity = Entity {
- ent_id :: AST.VHDLId, -- The id of the entity
- ent_args :: [Port], -- A mapping of each function argument to port names
- ent_res :: Port -- A mapping of the function result to port names
-} deriving (Show);
-
--- A orderable equivalent of CoreSyn's Type for use as a map key
-newtype OrdType = OrdType { getType :: Type.Type }
-instance Eq OrdType where
- (OrdType a) == (OrdType b) = Type.tcEqType a b
-instance Ord OrdType where
- compare (OrdType a) (OrdType b) = Type.tcCmpType a b
-
-data HType = StdType OrdType |
- ADTType String [HType] |
- VecType Int HType |
- SizedWType Int |
- RangedWType Int |
- SizedIType Int |
- BuiltinType String
- deriving (Eq, Ord)
-
--- A map of a Core type to the corresponding type name
-type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
-
--- A map of a vector Core element type and function name to the coressponding
--- VHDLId of the function and the function body.
-type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody)
-
--- A map of a Haskell function to a hardware signature
-type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
-
-type TfpIntMap = Map.Map OrdType Int
-
-data TypeState = TypeState {
- -- | A map of Core type -> VHDL Type
- vsTypes_ :: TypeMap,
- -- | A list of type declarations
- vsTypeDecls_ :: [AST.PackageDecItem],
- -- | A map of vector Core type -> VHDL type function
- vsTypeFuns_ :: TypeFunMap,
- vsTfpInts_ :: TfpIntMap,
- vsHscEnv_ :: HscTypes.HscEnv
-}
--- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''TypeState )
--- Define a session
-type TypeSession = State.State TypeState
-
-data VHDLState = VHDLState {
- -- | A subtype with typing info
- vsType_ :: TypeState,
- -- | A map of HsFunction -> hardware signature (entity name, port names,
- -- etc.)
- vsSignatures_ :: SignatureMap
-}
-
--- Derive accessors
-$( Data.Accessor.Template.deriveAccessors ''VHDLState )
-
--- | The state containing a VHDL Session
-type VHDLSession = State.State VHDLState
-
--- A function that generates VHDL for a builtin function
-type BuiltinBuilder =
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
- -> CoreSyn.CoreBndr -- ^ The function called
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
- -- dictionary arguments).
- -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements.
-
--- A map of a builtin function to VHDL function builder
-type NameTable = Map.Map String (Int, BuiltinBuilder )
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
-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
-
-executable: clash
-main-is: Main.hs
--- /dev/null
+{-# LANGUAGE PackageImports #-}
+--
+-- Functions to bring a Core expression in normal form. This module provides a
+-- top level function "normalize", and defines the actual transformation passes that
+-- are performed.
+--
+module Normalize (normalizeModule) where
+
+-- Standard modules
+import Debug.Trace
+import qualified Maybe
+import qualified "transformers" Control.Monad.Trans as Trans
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Data.Map as Map
+import qualified Data.Monoid as Monoid
+import Data.Accessor
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified CoreUtils
+import qualified Type
+import qualified TcType
+import qualified Id
+import qualified Var
+import qualified VarSet
+import qualified NameSet
+import qualified CoreFVs
+import qualified CoreUtils
+import qualified MkCore
+import qualified HscTypes
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import NormalizeTypes
+import NormalizeTools
+import VHDLTypes
+import CoreTools
+import Pretty
+
+--------------------------------
+-- Start of transformations
+--------------------------------
+
+--------------------------------
+-- η abstraction
+--------------------------------
+eta, etatop :: Transform
+eta expr | is_fun expr && not (is_lam expr) = do
+ let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
+ id <- mkInternalVar "param" arg_ty
+ change (Lam id (App expr (Var id)))
+-- Leave all other expressions unchanged
+eta e = return e
+etatop = notappargs ("eta", eta)
+
+--------------------------------
+-- β-reduction
+--------------------------------
+beta, betatop :: Transform
+-- Substitute arg for x in expr
+beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Propagate the application into the let
+beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
+-- Propagate the application into each of the alternatives
+beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
+ ty' = CoreUtils.applyTypeToArg ty arg
+-- Leave all other expressions unchanged
+beta expr = return expr
+-- Perform this transform everywhere
+betatop = everywhere ("beta", beta)
+
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop, castproptop :: Transform
+castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
+-- Leave all other expressions unchanged
+castprop expr = return expr
+-- Perform this transform everywhere
+castproptop = everywhere ("castprop", castprop)
+
+--------------------------------
+-- let recursification
+--------------------------------
+letrec, letrectop :: Transform
+letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
+-- Leave all other expressions unchanged
+letrec expr = return expr
+-- Perform this transform everywhere
+letrectop = everywhere ("letrec", letrec)
+
+--------------------------------
+-- let simplification
+--------------------------------
+letsimpl, letsimpltop :: Transform
+-- Put the "in ..." value of a let in its own binding, but not when the
+-- expression is applicable (to prevent loops with inlinefun).
+letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
+ local_var <- Trans.lift $ is_local_var res
+ if not local_var
+ then do
+ -- If the result is not a local var already (to prevent loops with
+ -- ourselves), extract it.
+ id <- mkInternalVar "foo" (CoreUtils.exprType res)
+ let bind = (id, res)
+ change $ Let (Rec (bind:binds)) (Var id)
+ else
+ -- If the result is already a local var, don't extract it.
+ return expr
+
+-- Leave all other expressions unchanged
+letsimpl expr = return expr
+-- Perform this transform everywhere
+letsimpltop = everywhere ("letsimpl", letsimpl)
+
+--------------------------------
+-- let flattening
+--------------------------------
+letflat, letflattop :: Transform
+letflat (Let (Rec binds) expr) = do
+ -- Turn each binding into a list of bindings (possibly containing just one
+ -- element, of course)
+ bindss <- Monad.mapM flatbind binds
+ -- Concat all the bindings
+ let binds' = concat bindss
+ -- Return the new let. We don't use change here, since possibly nothing has
+ -- changed. If anything has changed, flatbind has already flagged that
+ -- change.
+ return $ Let (Rec binds') expr
+ where
+ -- Turns a binding of a let into a multiple bindings, or any other binding
+ -- into a list with just that binding
+ flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
+ flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
+ flatbind (b, expr) = return [(b, expr)]
+-- Leave all other expressions unchanged
+letflat expr = return expr
+-- Perform this transform everywhere
+letflattop = everywhere ("letflat", letflat)
+
+--------------------------------
+-- Simple let binding removal
+--------------------------------
+-- Remove a = b bindings from let expressions everywhere
+letremovetop :: Transform
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
+
+--------------------------------
+-- Function inlining
+--------------------------------
+-- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
+-- expressions everywhere. This means that any value that still needs to be
+-- applied to something else (polymorphic values need to be applied to a
+-- Type) will be inlined, and will eventually be applied to all their
+-- arguments.
+--
+-- This is a tricky function, which is prone to create loops in the
+-- transformations. To fix this, we make sure that no transformation will
+-- create a new let binding with a function type. These other transformations
+-- will just not work on those function-typed values at first, but the other
+-- transformations (in particular β-reduction) should make sure that the type
+-- of those values eventually becomes primitive.
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
+
+--------------------------------
+-- Scrutinee simplification
+--------------------------------
+scrutsimpl,scrutsimpltop :: Transform
+-- Don't touch scrutinees that are already simple
+scrutsimpl expr@(Case (Var _) _ _ _) = return expr
+-- Replace all other cases with a let that binds the scrutinee and a new
+-- simple scrutinee, but not when the scrutinee is applicable (to prevent
+-- loops with inlinefun, though I don't think a scrutinee can be
+-- applicable...)
+scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
+ id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+-- Leave all other expressions unchanged
+scrutsimpl expr = return expr
+-- Perform this transform everywhere
+scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
+
+--------------------------------
+-- Case binder wildening
+--------------------------------
+casewild, casewildtop :: Transform
+casewild expr@(Case scrut b ty alts) = do
+ (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = concat bindingss
+ -- Replace the case with a let with bindings and a case
+ let newlet = (Let (Rec bindings) (Case scrut b ty alts'))
+ -- If there are no non-wild binders, or this case is already a simple
+ -- selector (i.e., a single alt with exactly one binding), already a simple
+ -- selector altan no bindings (i.e., no wild binders in the original case),
+ -- don't change anything, otherwise, replace the case.
+ if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
+ where
+ -- Generate a single wild binder, since they are all the same
+ wild = MkCore.mkWildBinder
+ -- Wilden the binders of one alt, producing a list of bindings as a
+ -- sideeffect.
+ doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
+ doalt (con, bndrs, expr) = do
+ bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- We replace the binders with wild binders only. We can leave expr
+ -- unchanged, since the new bindings bind the same vars as the original
+ -- did.
+ let newalt = (con, wildbndrs, expr)
+ return (bindings, newalt)
+ where
+ -- Make all binders wild
+ wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
+ -- A set of all the binders that are used by the expression
+ free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
+ -- Creates a case statement to retrieve the ith element from the scrutinee
+ -- and binds that to b.
+ mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
+ mkextracts b i =
+ if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
+ -- Don't create extra bindings for binders that are already wild
+ -- (e.g. not in the free variables of expr, so unused), or for
+ -- binders that bind function types (to prevent loops with
+ -- inlinefun).
+ then return Nothing
+ else do
+ -- Create on new binder that will actually capture a value in this
+ -- case statement, and return it
+ let bty = (Id.idType b)
+ id <- mkInternalVar "sel" bty
+ let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
+ return $ Just (b, Case scrut b bty [(con, binders, Var id)])
+-- Leave all other expressions unchanged
+casewild expr = return expr
+-- Perform this transform everywhere
+casewildtop = everywhere ("casewild", casewild)
+
+--------------------------------
+-- Case value simplification
+--------------------------------
+casevalsimpl, casevalsimpltop :: Transform
+casevalsimpl expr@(Case scrut b ty alts) = do
+ -- Try to simplify each alternative, resulting in an optional binding and a
+ -- new alternative.
+ (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- Create a new let around the case, that binds of the cases values.
+ let newlet = Let (Rec bindings) (Case scrut b ty alts')
+ -- If there were no values that needed and allowed simplification, don't
+ -- change the case.
+ if null bindings then return expr else change newlet
+ where
+ doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
+ -- Don't simplify values that are already simple
+ doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
+ -- Simplify each alt by creating a new id, binding the case value to it and
+ -- replacing the case value with that id. Only do this when the case value
+ -- does not use any of the binders bound by this alternative, for that would
+ -- cause those binders to become unbound when moving the value outside of
+ -- the case statement. Also, don't create a binding for applicable
+ -- expressions, to prevent loops with inlinefun.
+ doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
+ id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ -- We don't flag a change here, since casevalsimpl will do that above
+ -- based on Just we return here.
+ return $ (Just (id, expr), (con, bndrs, Var id))
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ -- Don't simplify anything else
+ doalt alt = return (Nothing, alt)
+-- Leave all other expressions unchanged
+casevalsimpl expr = return expr
+-- Perform this transform everywhere
+casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
+
+--------------------------------
+-- Case removal
+--------------------------------
+-- Remove case statements that have only a single alternative and only wild
+-- binders.
+caseremove, caseremovetop :: Transform
+-- Replace a useless case by the value of its single alternative
+caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+-- Leave all other expressions unchanged
+caseremove expr = return expr
+-- Perform this transform everywhere
+caseremovetop = everywhere ("caseremove", caseremove)
+
+--------------------------------
+-- Argument extraction
+--------------------------------
+-- Make sure that all arguments of a representable type are simple variables.
+appsimpl, appsimpltop :: Transform
+-- Simplify all representable arguments. Do this by introducing a new Let
+-- that binds the argument and passing the new binder in the application.
+appsimpl expr@(App f arg) = do
+ -- Check runtime representability
+ repr <- isRepr arg
+ local_var <- Trans.lift $ is_local_var arg
+ if repr && not local_var
+ then do -- Extract representable arguments
+ id <- mkInternalVar "arg" (CoreUtils.exprType arg)
+ change $ Let (Rec [(id, arg)]) (App f (Var id))
+ else -- Leave non-representable arguments unchanged
+ return expr
+-- Leave all other expressions unchanged
+appsimpl expr = return expr
+-- Perform this transform everywhere
+appsimpltop = everywhere ("appsimpl", appsimpl)
+
+--------------------------------
+-- Function-typed argument propagation
+--------------------------------
+-- Remove all applications to function-typed arguments, by duplication the
+-- function called with the function-typed parameter replaced by the free
+-- variables of the argument passed in.
+argprop, argproptop :: Transform
+-- Transform any application of a named function (i.e., skip applications of
+-- lambda's). Also skip applications that have arguments with free type
+-- variables, since we can't inline those.
+argprop expr@(App _ _) | is_var fexpr = do
+ -- Find the body of the function called
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ Just body -> do
+ -- Process each of the arguments in turn
+ (args', changed) <- Writer.listen $ mapM doarg args
+ -- See if any of the arguments changed
+ case Monoid.getAny changed of
+ True -> do
+ let (newargs', newparams', oldargs) = unzip3 args'
+ let newargs = concat newargs'
+ let newparams = concat newparams'
+ -- Create a new body that consists of a lambda for all new arguments and
+ -- the old body applied to some arguments.
+ let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
+ -- Create a new function with the same name but a new body
+ newf <- mkFunction f newbody
+ -- Replace the original application with one of the new function to the
+ -- new arguments.
+ change $ MkCore.mkCoreApps (Var newf) newargs
+ False ->
+ -- Don't change the expression if none of the arguments changed
+ return expr
+
+ -- If we don't have a body for the function called, leave it unchanged (it
+ -- should be a primitive function then).
+ Nothing -> return expr
+ where
+ -- Find the function called and the arguments
+ (fexpr, args) = collectArgs expr
+ Var f = fexpr
+
+ -- Process a single argument and return (args, bndrs, arg), where args are
+ -- the arguments to replace the given argument in the original
+ -- application, bndrs are the binders to include in the top-level lambda
+ -- in the new function body, and arg is the argument to apply to the old
+ -- function body.
+ doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
+ doarg arg = do
+ repr <- isRepr arg
+ bndrs <- Trans.lift getGlobalBinders
+ let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+ if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
+ then do
+ -- Propagate all complex arguments that are not representable, but not
+ -- arguments with free type variables (since those would require types
+ -- not known yet, which will always be known eventually).
+ -- Find interesting free variables, each of which should be passed to
+ -- the new function instead of the original function argument.
+ --
+ -- Interesting vars are those that are local, but not available from the
+ -- top level scope (functions from this module are defined as local, but
+ -- they're not local to this function, so we can freely move references
+ -- to them into another function).
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
+ -- Mark the current expression as changed
+ setChanged
+ return (map Var free_vars, free_vars, arg)
+ else do
+ -- Representable types will not be propagated, and arguments with free
+ -- type variables will be propagated later.
+ -- TODO: preserve original naming?
+ id <- mkBinderFor arg "param"
+ -- Just pass the original argument to the new function, which binds it
+ -- to a new id and just pass that new id to the old function body.
+ return ([arg], [id], mkReferenceTo id)
+-- Leave all other expressions unchanged
+argprop expr = return expr
+-- Perform this transform everywhere
+argproptop = everywhere ("argprop", argprop)
+
+--------------------------------
+-- Function-typed argument extraction
+--------------------------------
+-- This transform takes any function-typed argument that cannot be propagated
+-- (because the function that is applied to it is a builtin function), and
+-- puts it in a brand new top level binder. This allows us to for example
+-- apply map to a lambda expression This will not conflict with inlinefun,
+-- since that only inlines local let bindings, not top level bindings.
+funextract, funextracttop :: Transform
+funextract expr@(App _ _) | is_var fexpr = do
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ -- We don't have a function body for f, so we can perform this transform.
+ Nothing -> do
+ -- Find the new arguments
+ args' <- mapM doarg args
+ -- And update the arguments. We use return instead of changed, so the
+ -- changed flag doesn't get set if none of the args got changed.
+ return $ MkCore.mkCoreApps fexpr args'
+ -- We have a function body for f, leave this application to funprop
+ Just _ -> return expr
+ where
+ -- Find the function called and the arguments
+ (fexpr, args) = collectArgs expr
+ Var f = fexpr
+ -- Change any arguments that have a function type, but are not simple yet
+ -- (ie, a variable or application). This means to create a new function
+ -- for map (\f -> ...) b, but not for map (foo a) b.
+ --
+ -- We could use is_applicable here instead of is_fun, but I think
+ -- arguments to functions could only have forall typing when existential
+ -- typing is enabled. Not sure, though.
+ doarg arg | not (is_simple arg) && is_fun arg = do
+ -- Create a new top level binding that binds the argument. Its body will
+ -- be extended with lambda expressions, to take any free variables used
+ -- by the argument expression.
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
+ let body = MkCore.mkCoreLams free_vars arg
+ id <- mkBinderFor body "fun"
+ Trans.lift $ addGlobalBind id body
+ -- Replace the argument with a reference to the new function, applied to
+ -- all vars it uses.
+ change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
+ -- Leave all other arguments untouched
+ doarg arg = return arg
+
+-- Leave all other expressions unchanged
+funextract expr = return expr
+-- Perform this transform everywhere
+funextracttop = everywhere ("funextract", funextract)
+
+--------------------------------
+-- End of transformations
+--------------------------------
+
+
+
+
+-- What transforms to run?
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+
+-- Turns the given bind into VHDL
+normalizeModule ::
+ HscTypes.HscEnv
+ -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+ -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
+ -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
+ -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
+ -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
+
+normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do
+ -- Put all the bindings in this module in the tsBindings map
+ putA tsBindings (Map.fromList bindings)
+ -- (Recursively) normalize each of the requested bindings
+ mapM normalizeBind generate_for
+ -- Get all initial bindings and the ones we produced
+ bindings_map <- getA tsBindings
+ let bindings = Map.assocs bindings_map
+ normalized_bindings <- getA tsNormalized
+ typestate <- getA tsType
+ -- But return only the normalized bindings
+ return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
+
+normalizeBind :: CoreBndr -> TransformSession ()
+normalizeBind bndr =
+ -- Don't normalize global variables, these should be either builtin
+ -- functions or data constructors.
+ Monad.when (Var.isLocalId bndr) $ do
+ -- Skip binders that have a polymorphic type, since it's impossible to
+ -- create polymorphic hardware.
+ if is_poly (Var bndr)
+ then
+ -- This should really only happen at the top level... TODO: Give
+ -- a different error if this happens down in the recursion.
+ error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
+ else do
+ normalized_funcs <- getA tsNormalized
+ -- See if this function was normalized already
+ if VarSet.elemVarSet bndr normalized_funcs
+ then
+ -- Yup, don't do it again
+ return ()
+ else do
+ -- Nope, note that it has been and do it.
+ modA tsNormalized (flip VarSet.extendVarSet bndr)
+ expr_maybe <- getGlobalBind bndr
+ case expr_maybe of
+ Just expr -> do
+ -- Introduce an empty Let at the top level, so there will always be
+ -- a let in the expression (none of the transformations will remove
+ -- the last let).
+ let expr' = Let (Rec []) expr
+ -- Normalize this expression
+ trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ -- And store the normalized version in the session
+ modA tsBindings (Map.insert bndr expr')
+ -- Find all vars used with a function type. All of these should be global
+ -- binders (i.e., functions used), since any local binders with a function
+ -- type should have been inlined already.
+ bndrs <- getGlobalBinders
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
+ let used_funcs = VarSet.varSetElems used_funcs_set
+ -- Process each of the used functions recursively
+ mapM normalizeBind used_funcs
+ return ()
+ -- We don't have a value for this binder. This really shouldn't
+ -- happen for local id's...
+ Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
--- /dev/null
+{-# LANGUAGE PackageImports #-}
+--
+-- This module provides functions for program transformations.
+--
+module NormalizeTools where
+-- Standard modules
+import Debug.Trace
+import qualified List
+import qualified Data.Monoid as Monoid
+import qualified Data.Either as Either
+import qualified Control.Arrow as Arrow
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified "transformers" Control.Monad.Trans as Trans
+import qualified Data.Map as Map
+import Data.Accessor
+import Data.Accessor.MonadState as MonadState
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified Unique
+import qualified OccName
+import qualified Name
+import qualified Var
+import qualified SrcLoc
+import qualified Type
+import qualified IdInfo
+import qualified CoreUtils
+import qualified CoreSubst
+import qualified VarSet
+import qualified HscTypes
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import NormalizeTypes
+import Pretty
+import VHDLTypes
+import qualified 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,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
+mkInternalVar str ty = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
+
+-- Create a new type variable with the given name and kind. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
+mkTypeVar str kind = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkTyVar name kind
+
+-- Creates a binder for the given expression with the given name. This
+-- works for both value and type level expressions, so it can return a Var or
+-- TyVar (which is just an alias for Var).
+mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
+mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
+mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
+
+-- Creates a reference to the given variable. This works for both a normal
+-- variable as well as a type variable
+mkReferenceTo :: Var.Var -> CoreExpr
+mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
+ | otherwise = (Var var)
+
+cloneVar :: Var.Var -> TransformMonad Var.Var
+cloneVar v = do
+ uniq <- mkUnique
+ -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
+ -- contains, but vannillaIdInfo is always correct, since it means "no info").
+ return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+
+-- Creates a new function with the same name as the given binder (but with a
+-- new unique) and with the given function body. Returns the new binder for
+-- this function.
+mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
+mkFunction bndr body = do
+ let ty = CoreUtils.exprType body
+ id <- cloneVar bndr
+ let newid = Var.setVarType id ty
+ Trans.lift $ addGlobalBind newid body
+ return newid
+
+-- Apply the given transformation to all expressions in the given expression,
+-- including the expression itself.
+everywhere :: (String, Transform) -> Transform
+everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
+
+-- Apply the first transformation, followed by the second transformation, and
+-- keep applying both for as long as expression still changes.
+applyboth :: Transform -> (String, Transform) -> Transform
+applyboth first (name, second) expr = do
+ -- Apply the first
+ expr' <- first expr
+ -- Apply the second
+ (expr'', changed) <- Writer.listen $ second expr'
+ if Monoid.getAny $
+-- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
+ changed
+ then
+-- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
+-- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
+ applyboth first (name, second) $
+ expr''
+ else
+-- trace ("No changes") $
+ return expr''
+
+-- Apply the given transformation to all direct subexpressions (only), not the
+-- expression itself.
+subeverywhere :: Transform -> Transform
+subeverywhere trans (App a b) = do
+ a' <- trans a
+ b' <- trans b
+ return $ App a' b'
+
+subeverywhere trans (Let (NonRec b bexpr) expr) = do
+ bexpr' <- trans bexpr
+ expr' <- trans expr
+ return $ Let (NonRec b bexpr') expr'
+
+subeverywhere trans (Let (Rec binds) expr) = do
+ expr' <- trans expr
+ binds' <- mapM transbind binds
+ return $ Let (Rec binds') expr'
+ where
+ transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ transbind (b, e) = do
+ e' <- trans e
+ return (b, e')
+
+subeverywhere trans (Lam x expr) = do
+ expr' <- trans expr
+ return $ Lam x expr'
+
+subeverywhere trans (Case scrut b t alts) = do
+ scrut' <- trans scrut
+ alts' <- mapM transalt alts
+ return $ Case scrut' b t alts'
+ where
+ transalt :: CoreAlt -> TransformMonad CoreAlt
+ transalt (con, binders, expr) = do
+ expr' <- trans expr
+ return (con, binders, expr')
+
+subeverywhere trans (Var x) = return $ Var x
+subeverywhere trans (Lit x) = return $ Lit x
+subeverywhere trans (Type x) = return $ Type x
+
+subeverywhere trans (Cast expr ty) = do
+ expr' <- trans expr
+ return $ Cast expr' ty
+
+subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
+
+-- Apply the given transformation to all expressions, except for direct
+-- arguments of an application
+notappargs :: (String, Transform) -> Transform
+notappargs trans = applyboth (subnotappargs trans) trans
+
+-- Apply the given transformation to all (direct and indirect) subexpressions
+-- (but not the expression itself), except for direct arguments of an
+-- application
+subnotappargs :: (String, Transform) -> Transform
+subnotappargs trans (App a b) = do
+ a' <- subnotappargs trans a
+ b' <- subnotappargs trans b
+ return $ App a' b'
+
+-- Let subeverywhere handle all other expressions
+subnotappargs trans expr = subeverywhere (notappargs trans) expr
+
+-- Runs each of the transforms repeatedly inside the State monad.
+dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
+dotransforms transs expr = do
+ (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
+ if Monoid.getAny changed then dotransforms transs expr' else return expr'
+
+-- Inline all let bindings that satisfy the given condition
+inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
+inlinebind condition expr@(Let (Rec binds) res) = do
+ -- Find all bindings that adhere to the condition
+ res_eithers <- mapM docond binds
+ case Either.partitionEithers res_eithers of
+ -- No replaces? No change
+ ([], _) -> return expr
+ (replace, others) -> do
+ -- Substitute the to be replaced binders with their expression
+ let newexpr = substitute replace (Let (Rec others) res)
+ change newexpr
+ where
+ docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
+ docond b = do
+ res <- condition b
+ return $ case res of True -> Left b; False -> Right b
+
+-- Leave all other expressions unchanged
+inlinebind _ expr = return expr
+
+-- Sets the changed flag in the TransformMonad, to signify that some
+-- transform has changed the result
+setChanged :: TransformMonad ()
+setChanged = Writer.tell (Monoid.Any True)
+
+-- Sets the changed flag and returns the given value.
+change :: a -> TransformMonad a
+change val = do
+ setChanged
+ return val
+
+-- Create a new Unique
+mkUnique :: TransformMonad Unique.Unique
+mkUnique = Trans.lift $ do
+ us <- getA tsUniqSupply
+ let (us', us'') = UniqSupply.splitUniqSupply us
+ putA tsUniqSupply us'
+ return $ UniqSupply.uniqFromSupply us''
+
+-- Replace each of the binders given with the coresponding expressions in the
+-- given expression.
+substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
+substitute [] expr = expr
+-- Apply one substitution on the expression, but also on any remaining
+-- substitutions. This seems to be the only way to handle substitutions like
+-- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
+-- according to CoreSubst documentation (but it doesn't seem to be a problem).
+-- TODO: Find out how this works, exactly.
+substitute ((b, e):subss) expr = substitute subss' expr'
+ where
+ -- Create the Subst
+ subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
+ -- Apply this substitution to the main expression
+ expr' = CoreSubst.substExpr subs expr
+ -- Apply this substitution on all the expressions in the remaining
+ -- substitutions
+ subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
+
+-- Run a given TransformSession. Used mostly to setup the right calls and
+-- an initial state.
+runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a
+runTransformSession env uniqSupply session = State.evalState session emptyTransformState
+ where
+ emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env
+ emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState
+
+-- Is the given expression representable at runtime, based on the type?
+isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
+isRepr (Type ty) = return False
+isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
+
+is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool
+is_local_var (CoreSyn.Var v) = do
+ bndrs <- getGlobalBinders
+ return $ not $ v `elem` bndrs
+is_local_var _ = return False
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+module NormalizeTypes where
+
+
+-- Standard modules
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Monoid as Monoid
+import qualified Data.Accessor.Template
+import Data.Accessor
+import qualified Data.Map as Map
+import Debug.Trace
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified VarSet
+import Outputable ( Outputable, showSDoc, ppr )
+
+-- Local imports
+import CoreShow
+import Pretty
+import VHDLTypes -- For TypeState
+
+data TransformState = TransformState {
+ tsUniqSupply_ :: UniqSupply.UniqSupply
+ , tsBindings_ :: Map.Map CoreBndr CoreExpr
+ , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
+ , tsType_ :: TypeState
+}
+
+$( Data.Accessor.Template.deriveAccessors ''TransformState )
+
+-- A session of multiple transformations over multiple expressions
+type TransformSession = (State.State TransformState)
+-- Wrap a writer around a TransformSession, to run a single transformation
+-- over a single expression and track if the expression was changed.
+type TransformMonad = Writer.WriterT Monoid.Any TransformSession
+
+-- | Transforms a CoreExpr and keeps track if it has changed.
+type Transform = CoreExpr -> TransformMonad CoreExpr
+
+-- Finds the value of a global binding, if available
+getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr)
+getGlobalBind bndr = do
+ bindings <- getA tsBindings
+ return $ Map.lookup bndr bindings
+
+-- Adds a new global binding with the given value
+addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession ()
+addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr)
+
+-- Returns a list of all global binders
+getGlobalBinders :: TransformSession [CoreBndr]
+getGlobalBinders = do
+ bindings <- getA tsBindings
+ return $ Map.keys bindings
--- /dev/null
+module Translator where
+import qualified Directory
+import qualified System.FilePath as FilePath
+import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
+import GHC hiding (loadModule, sigName)
+import CoreSyn
+import qualified CoreUtils
+import qualified Var
+import qualified Type
+import qualified TyCon
+import qualified DataCon
+import qualified HscMain
+import qualified SrcLoc
+import qualified FastString
+import qualified Maybe
+import qualified Module
+import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State
+import Name
+import qualified Data.Map as Map
+import Data.Accessor
+import Data.Generics
+import NameEnv ( lookupNameEnv )
+import qualified HscTypes
+import HscTypes ( cm_binds, cm_types )
+import MonadUtils ( liftIO )
+import Outputable ( showSDoc, ppr, showSDocDebug )
+import GHC.Paths ( libdir )
+import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
+import List ( find )
+import qualified List
+import qualified Monad
+
+-- The following modules come from the ForSyDe project. They are really
+-- internal modules, so ForSyDe.cabal has to be modified prior to installing
+-- ForSyDe to get access to these modules.
+import qualified Language.VHDL.AST as AST
+import qualified Language.VHDL.FileIO
+import qualified Language.VHDL.Ppr as Ppr
+-- This is needed for rendering the pretty printed VHDL
+import Text.PrettyPrint.HughesPJ (render)
+
+import TranslatorTypes
+import HsValueMap
+import Pretty
+import Normalize
+-- import Flatten
+-- import FlattenTypes
+import VHDLTypes
+import qualified VHDL
+
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
+ -- Load the module
+ (core, env) <- loadModule filename
+ -- Translate to VHDL
+ vhdl <- moduleToVHDL env core [(name, stateful)]
+ -- Write VHDL to file
+ let dir = "./vhdl/" ++ name ++ "/"
+ prepareDir dir
+ mapM (writeVHDL dir) vhdl
+ return ()
+
+listBindings :: String -> IO [()]
+listBindings filename = do
+ (core, env) <- loadModule filename
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ mapM (listBinding) binds
+
+listBinding :: (CoreBndr, CoreExpr) -> IO ()
+listBinding (b, e) = do
+ putStr "\nBinder: "
+ putStr $ show b
+ putStr "\nExpression: \n"
+ putStr $ prettyShow e
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr e
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr $ CoreUtils.exprType e
+ putStr "\n\n"
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: String -> String -> IO ()
+listBind filename name = do
+ (core, env) <- loadModule filename
+ let [(b, expr)] = findBinds core [name]
+ putStr "\n"
+ putStr $ prettyShow expr
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr expr
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
+ putStr "\n\n"
+
+-- | Translate the binds with the given names from the given core module to
+-- VHDL. The Bool in the tuple makes the function stateful (True) or
+-- stateless (False).
+moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env core list = do
+ let (names, statefuls) = unzip list
+ let binds = map fst $ findBinds core names
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+ -- unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ -- Turn bind into VHDL
+ let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+ let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ return vhdl
+ where
+
+-- | Prepares the directory for writing VHDL files. This means creating the
+-- dir if it does not exist and removing all existing .vhdl files from it.
+prepareDir :: String -> IO()
+prepareDir dir = do
+ -- Create the dir if needed
+ exists <- Directory.doesDirectoryExist dir
+ Monad.unless exists $ Directory.createDirectory dir
+ -- Find all .vhdl files in the directory
+ files <- Directory.getDirectoryContents dir
+ let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
+ -- Prepend the dirname to the filenames
+ let abs_to_remove = map (FilePath.combine dir) to_remove
+ -- Remove the files
+ mapM_ Directory.removeFile abs_to_remove
+
+-- | Write the given design file to a file with the given name inside the
+-- given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
+ -- Find the filename
+ let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
+ -- Write the file
+ Language.VHDL.FileIO.writeDesignFile vhdl fname
+
+-- | Loads the given file and turns it into a core module.
+loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
+loadModule filename =
+ defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ --target <- guessTarget "adder.hs" Nothing
+ --liftIO (print (showSDoc (ppr (target))))
+ --liftIO $ printTarget target
+ --setTargets [target]
+ --load LoadAllTargets
+ --core <- GHC.compileToCoreSimplified "Adders.hs"
+ core <- GHC.compileToCoreModule filename
+ env <- GHC.getSession
+ return (core, env)
+
+-- | Extracts the named binds from the given module.
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
+
+-- | Extract a named bind from the given list of binds
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
+findBind binds lookfor =
+ -- This ignores Recs and compares the name of the bind with lookfor,
+ -- disregarding any namespaces in OccName and extra attributes in Name and
+ -- Var.
+ find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
+
+-- | Flattens the given bind into the given signature and adds it to the
+-- session. Then (recursively) finds any functions it uses and does the same
+-- with them.
+-- flattenBind ::
+-- HsFunction -- The signature to flatten into
+-- -> (CoreBndr, CoreExpr) -- The bind to flatten
+-- -> TranslatorState ()
+--
+-- flattenBind hsfunc bind@(var, expr) = do
+-- -- Flatten the function
+-- let flatfunc = flattenFunction hsfunc bind
+-- -- Propagate state variables
+-- let flatfunc' = propagateState hsfunc flatfunc
+-- -- Store the flat function in the session
+-- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+-- -- Flatten any functions used
+-- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+-- mapM_ resolvFunc used_hsfuncs
+
+-- | Decide which incoming state variables will become state in the
+-- given function, and which will be propagate to other applied
+-- functions.
+-- propagateState ::
+-- HsFunction
+-- -> FlatFunction
+-- -> FlatFunction
+--
+-- propagateState hsfunc flatfunc =
+-- flatfunc {flat_defs = apps', flat_sigs = sigs'}
+-- where
+-- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+-- states' = zip olds news
+-- -- Find all signals used by all sigdefs
+-- uses = concatMap sigDefUses (flat_defs flatfunc)
+-- -- Find all signals that are used more than once (is there a
+-- -- prettier way to do this?)
+-- multiple_uses = uses List.\\ (List.nub uses)
+-- -- Find the states whose "old state" signal is used only once
+-- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+-- -- See if these single use states can be propagated
+-- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+-- substate_sigs = concat substate_sigss
+-- -- Mark any propagated state signals as SigSubState
+-- sigs' = map
+-- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+-- (flat_sigs flatfunc)
+
+-- | Propagate the state into a single function application.
+-- propagateState' ::
+-- [(SignalId, SignalId)]
+-- -- ^ TODO
+-- -> SigDef -- ^ The SigDef to process.
+-- -> ([SignalId], SigDef)
+-- -- ^ Any signal ids that should become substates,
+-- -- and the resulting application.
+--
+-- propagateState' states def =
+-- if (is_FApp def) then
+-- (our_old ++ our_new, def {appFunc = hsfunc'})
+-- else
+-- ([], def)
+-- where
+-- hsfunc = appFunc def
+-- args = appArgs def
+-- res = appRes def
+-- our_states = filter our_state states
+-- -- A state signal belongs in this function if the old state is
+-- -- passed in, and the new state returned
+-- our_state (old, new) =
+-- any (old `Foldable.elem`) args
+-- && new `Foldable.elem` res
+-- (our_old, our_new) = unzip our_states
+-- -- Mark the result
+-- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+-- res' = fmap (mark_state (zip our_new [0..])) zipped_res
+-- -- Mark the args
+-- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+-- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+-- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+--
+-- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+-- mark_state states (id, use) =
+-- case lookup id states of
+-- Nothing -> use
+-- Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+-- getStateSignals ::
+-- HsFunction -- | The function to look at
+-- -> FlatFunction -- | The function to look at
+-- -> [(SignalId, SignalId)]
+-- -- | TODO The state signals. The first is the state number, the second the
+-- -- signal to assign the current state to, the last is the signal
+-- -- that holds the new state.
+--
+-- getStateSignals hsfunc flatfunc =
+-- [(old_id, new_id)
+-- | (old_num, old_id) <- args
+-- , (new_num, new_id) <- res
+-- , old_num == new_num]
+-- where
+-- sigs = flat_sigs flatfunc
+-- -- Translate args and res to lists of (statenum, sigid)
+-- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+-- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+
+-- | Find the given function, flatten it and add it to the session. Then
+-- (recursively) do the same for any functions used.
+-- resolvFunc ::
+-- HsFunction -- | The function to look for
+-- -> TranslatorState ()
+--
+-- resolvFunc hsfunc = do
+-- flatfuncmap <- getA tsFlatFuncs
+-- -- Don't do anything if there is already a flat function for this hsfunc or
+-- -- when it is a builtin function.
+-- Monad.unless (Map.member hsfunc flatfuncmap) $ do
+-- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+-- -- New function, resolve it
+-- core <- getA tsCoreModule
+-- -- Find the named function
+-- let name = (hsFuncName hsfunc)
+-- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
+-- case bind of
+-- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+-- Just b -> flattenBind hsfunc b
+
+-- | Translate a top level function declaration to a HsFunction. i.e., which
+-- interface will be provided by this function. This function essentially
+-- defines the "calling convention" for hardware models.
+-- mkHsFunction ::
+-- Var.Var -- ^ The function defined
+-- -> Type -- ^ The function type (including arguments!)
+-- -> Bool -- ^ Is this a stateful function?
+-- -> HsFunction -- ^ The resulting HsFunction
+--
+-- mkHsFunction f ty stateful=
+-- HsFunction hsname hsargs hsres
+-- where
+-- hsname = getOccString f
+-- (arg_tys, res_ty) = Type.splitFunTys ty
+-- (hsargs, hsres) =
+-- if stateful
+-- then
+-- let
+-- -- The last argument must be state
+-- state_ty = last arg_tys
+-- state = useAsState (mkHsValueMap state_ty)
+-- -- All but the last argument are inports
+-- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+-- hsargs = inports ++ [state]
+-- hsres = case splitTupleType res_ty of
+-- -- Result type must be a two tuple (state, ports)
+-- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+-- then
+-- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+-- else
+-- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+-- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+-- in
+-- (hsargs, hsres)
+-- else
+-- -- Just use everything as a port
+-- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
+
+-- | Adds signal names to the given FlatFunction
+-- nameFlatFunction ::
+-- FlatFunction
+-- -> FlatFunction
+--
+-- nameFlatFunction flatfunc =
+-- -- Name the signals
+-- let
+-- s = flat_sigs flatfunc
+-- s' = map nameSignal s in
+-- flatfunc { flat_sigs = s' }
+-- where
+-- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+-- nameSignal (id, info) =
+-- let hints = nameHints info in
+-- let parts = ("sig" : hints) ++ [show id] in
+-- let name = concat $ List.intersperse "_" parts in
+-- (id, info {sigName = Just name})
+--
+-- -- | Splits a tuple type into a list of element types, or Nothing if the type
+-- -- is not a tuple type.
+-- splitTupleType ::
+-- Type -- ^ The type to split
+-- -> Maybe [Type] -- ^ The tuples element types
+--
+-- splitTupleType ty =
+-- case Type.splitTyConApp_maybe ty of
+-- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
+-- then
+-- Just args
+-- else
+-- Nothing
+-- Nothing -> Nothing
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+--
+-- Simple module providing some types used by Translator. These are in a
+-- separate module to prevent circular dependencies in Pretty for example.
+--
+{-# LANGUAGE TemplateHaskell #-}
+module TranslatorTypes where
+
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Map as Map
+import qualified Data.Accessor.Template
+import Data.Accessor
+
+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
+
+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
+}
+
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''TranslatorSession )
+
+type TranslatorState = State.State TranslatorSession
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
+module CoreShow where
+
+-- This module derives Show instances for CoreSyn types.
+
+import qualified BasicTypes
+
+import qualified CoreSyn
+import qualified TypeRep
+import qualified TyCon
+
+import qualified HsTypes
+import qualified HsExpr
+import qualified HsBinds
+import qualified SrcLoc
+import qualified RdrName
+
+import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
+
+
+-- Derive Show for core expressions and binders, so we can see the actual
+-- structure.
+deriving instance (Show b) => Show (CoreSyn.Expr b)
+deriving instance (Show b) => Show (CoreSyn.Bind b)
+deriving instance Show TypeRep.Type
+deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n)
+deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n)
+deriving instance (Show x) => Show (SrcLoc.Located x)
+deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x)
+deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x)
+deriving instance Show (RdrName.RdrName)
+deriving instance (Show idL, Show idR, OutputableBndr idL, OutputableBndr idR) => Show (HsBinds.HsBindLR idL idR)
+deriving instance Show CoreSyn.Note
+
+
+-- Implement dummy shows, since deriving them will need loads of other shows
+-- as well.
+instance Show TypeRep.PredType where
+ show t = "_PredType:(" ++ (showSDoc $ ppr t) ++ ")"
+instance Show TyCon.TyCon where
+ show t = "_TyCon:(" ++ (showSDoc $ ppr t) ++ ")"
+instance Show BasicTypes.Boxity where
+ show b = "_Boxity"
+instance Show HsTypes.HsExplicitForAll where
+ show b = "_HsExplicitForAll"
+instance Show HsExpr.HsArrAppType where
+ show b = "_HsArrAppType"
+instance Show (HsExpr.MatchGroup x) where
+ show b = "_HsMatchGroup"
+instance Show (HsExpr.GroupByClause x) where
+ show b = "_GroupByClause"
+instance Show (HsExpr.HsStmtContext x) where
+ show b = "_HsStmtContext"
+instance Show (HsBinds.Prag) where
+ show b = "_Prag"
+instance Show (HsExpr.GRHSs id) where
+ show b = "_GRHSs"
+
+
+instance (Outputable x) => Show x where
+ show x = "__" ++ (showSDoc $ ppr x) ++ "__"
--- /dev/null
+-- | This module provides a number of functions to find out things about Core
+-- programs. This module does not provide the actual plumbing to work with
+-- Core and Haskell (it uses HsTools for this), but only the functions that
+-- know about various libraries and know which functions to call.
+module CoreTools where
+
+--Standard modules
+import qualified Maybe
+import System.IO.Unsafe
+
+-- GHC API
+import qualified GHC
+import qualified Type
+import qualified TcType
+import qualified HsExpr
+import qualified HsTypes
+import qualified HsBinds
+import qualified HscTypes
+import qualified RdrName
+import qualified Name
+import qualified OccName
+import qualified TysWiredIn
+import qualified Bag
+import qualified DynFlags
+import qualified SrcLoc
+import qualified CoreSyn
+import qualified Var
+import qualified VarSet
+import qualified Unique
+import qualified CoreUtils
+import qualified CoreFVs
+import qualified Literal
+
+-- Local imports
+import GhcTools
+import HsTools
+import Pretty
+
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int.
+eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
+eval_tfp_int env ty =
+ unsafeRunGhc $ do
+ GHC.setSession env
+ -- Automatically import modules for any fully qualified identifiers
+ setDynFlag DynFlags.Opt_ImplicitImportQualified
+
+ let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
+ let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
+ let undef = hsTypedUndef $ coreToHsType ty
+ let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
+ let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
+ let expr = HsExpr.ExprWithTySig app int_ty
+ core <- toCore expr
+ execCore core
+
+normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
+normalise_tfp_int env ty =
+ unsafePerformIO $ do
+ nty <- normaliseType env ty
+ return nty
+
+-- | Get the width of a SizedWord type
+-- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
+
+sized_word_len_ty :: Type.Type -> Type.Type
+sized_word_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
+ [len] = args
+
+-- | Get the width of a SizedInt type
+-- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
+
+sized_int_len_ty :: Type.Type -> Type.Type
+sized_int_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
+ [len] = args
+
+-- | Get the upperbound of a RangedWord type
+-- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
+-- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
+
+ranged_word_bound_ty :: Type.Type -> Type.Type
+ranged_word_bound_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
+ [len] = args
+
+-- | Evaluate a core Type representing type level int from the TypeLevel
+-- library to a real int.
+-- eval_type_level_int :: Type.Type -> Int
+-- eval_type_level_int ty =
+-- unsafeRunGhc $ do
+-- -- Automatically import modules for any fully qualified identifiers
+-- setDynFlag DynFlags.Opt_ImplicitImportQualified
+--
+-- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
+-- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
+-- let undef = hsTypedUndef $ coreToHsType ty
+-- let app = HsExpr.HsApp (to_int) (undef)
+--
+-- core <- toCore [] app
+-- execCore core
+
+-- | Get the length of a FSVec type
+-- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
+
+tfvec_len_ty :: Type.Type -> Type.Type
+tfvec_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
+ [len, el_ty] = args
+
+-- | Get the element type of a TFVec type
+tfvec_elem :: Type.Type -> Type.Type
+tfvec_elem ty = el_ty
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
+ [len, el_ty] = args
+
+-- Is the given core expression a lambda abstraction?
+is_lam :: CoreSyn.CoreExpr -> Bool
+is_lam (CoreSyn.Lam _ _) = True
+is_lam _ = False
+
+-- Is the given core expression of a function type?
+is_fun :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_fun (CoreSyn.Type _) = False
+is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
+
+-- Is the given core expression polymorphic (i.e., does it accept type
+-- arguments?).
+is_poly :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_poly (CoreSyn.Type _) = False
+is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
+
+-- Is the given core expression a variable reference?
+is_var :: CoreSyn.CoreExpr -> Bool
+is_var (CoreSyn.Var _) = True
+is_var _ = False
+
+is_lit :: CoreSyn.CoreExpr -> Bool
+is_lit (CoreSyn.Lit _) = True
+is_lit _ = False
+
+-- Can the given core expression be applied to something? This is true for
+-- applying to a value as well as a type.
+is_applicable :: CoreSyn.CoreExpr -> Bool
+is_applicable expr = is_fun expr || is_poly expr
+
+-- Is the given core expression a variable or an application?
+is_simple :: CoreSyn.CoreExpr -> Bool
+is_simple (CoreSyn.App _ _) = True
+is_simple (CoreSyn.Var _) = True
+is_simple (CoreSyn.Cast expr _) = is_simple expr
+is_simple _ = False
+
+-- Does the given CoreExpr have any free type vars?
+has_free_tyvars :: CoreSyn.CoreExpr -> Bool
+has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
+
+-- Does the given CoreExpr have any free local vars?
+has_free_vars :: CoreSyn.CoreExpr -> Bool
+has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
+
+-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
+-- simple Var CoreExprs, not complexer ones.
+exprToVar :: CoreSyn.CoreExpr -> Var.Id
+exprToVar (CoreSyn.Var id) = id
+exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
+
+-- Turns a Lit CoreExpr into the Literal inside it.
+exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
+exprToLit (CoreSyn.Lit lit) = lit
+exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
+
+-- Removes all the type and dictionary arguments from the given argument list,
+-- leaving only the normal value arguments. The type given is the type of the
+-- expression applied to this argument list.
+get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
+get_val_args ty args = drop n args
+ where
+ (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
+ -- The first (length tyvars) arguments should be types, the next
+ -- (length predtypes) arguments should be dictionaries. We drop this many
+ -- arguments, to get at the value arguments.
+ n = length tyvars + length predtypes
+
+getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
+getLiterals app@(CoreSyn.App _ _) = literals
+ where
+ (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ literals = filter (is_lit) args
--- /dev/null
+module GhcTools where
+-- Standard modules
+import qualified System.IO.Unsafe
+
+-- GHC API
+import qualified GHC
+import qualified GHC.Paths
+import qualified DynFlags
+import qualified TcRnMonad
+import qualified MonadUtils
+import qualified HscTypes
+import qualified PrelNames
+
+-- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
+-- be no standard function to do exactly this.
+setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
+setDynFlag dflag = do
+ dflags <- GHC.getSessionDynFlags
+ let dflags' = DynFlags.dopt_set dflags dflag
+ GHC.setSessionDynFlags dflags'
+ return ()
+
+-- We don't want the IO monad sprinkled around everywhere, so we hide it.
+-- This should be safe as long as we only do simple things in the GhcMonad
+-- such as interface lookups and evaluating simple expressions that
+-- don't have side effects themselves (Or rather, that don't use
+-- unsafePerformIO themselves, since normal side effectful function would
+-- just return an IO monad when they are evaluated).
+unsafeRunGhc :: GHC.Ghc a -> a
+unsafeRunGhc m =
+ System.IO.Unsafe.unsafePerformIO $
+ GHC.runGhc (Just GHC.Paths.libdir) $ do
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ m
+
+runTcM :: TcRnMonad.TcM a -> IO a
+runTcM thing_inside = do
+ GHC.runGhc (Just GHC.Paths.libdir) $ do
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ env <- GHC.getSession
+ HscTypes.ioMsgMaybe . MonadUtils.liftIO . TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ thing_inside
--- /dev/null
+{-# LANGUAGE ViewPatterns #-}
+module HsTools where
+
+-- Standard modules
+import qualified Unsafe.Coerce
+import qualified Maybe
+
+-- GHC API
+import qualified GHC
+import qualified HscMain
+import qualified HscTypes
+import qualified DynFlags
+import qualified FastString
+import qualified StringBuffer
+import qualified MonadUtils
+import Outputable ( showSDoc, ppr )
+import qualified Outputable
+-- Lexer & Parser, i.e. up to HsExpr
+import qualified Lexer
+import qualified Parser
+-- HsExpr representation, renaming, typechecking and desugaring
+-- (i.e., everything up to Core).
+import qualified HsSyn
+import qualified HsExpr
+import qualified HsTypes
+import qualified HsBinds
+import qualified TcRnMonad
+import qualified TcRnTypes
+import qualified RnExpr
+import qualified RnEnv
+import qualified TcExpr
+import qualified TcEnv
+import qualified TcSimplify
+import qualified TcTyFuns
+import qualified Desugar
+import qualified InstEnv
+import qualified FamInstEnv
+import qualified PrelNames
+import qualified Module
+import qualified OccName
+import qualified RdrName
+import qualified Name
+import qualified TysWiredIn
+import qualified SrcLoc
+import qualified LoadIface
+import qualified BasicTypes
+import qualified Bag
+-- Core representation and handling
+import qualified CoreSyn
+import qualified Id
+import qualified Type
+import qualified TyCon
+
+
+-- Local imports
+import GhcTools
+import CoreShow
+
+-- | Translate a HsExpr to a Core expression. This does renaming, type
+-- checking, simplification of class instances and desugaring. The result is
+-- a let expression that holds the given expression and a number of binds that
+-- are needed for any type classes used to work. For example, the HsExpr:
+-- \x = x == (1 :: Int)
+-- will result in the CoreExpr
+-- let
+-- $dInt = ...
+-- (==) = Prelude.(==) Int $dInt
+-- in
+-- \x = (==) x 1
+toCore ::
+ HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
+ -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
+toCore expr = do
+ env <- GHC.getSession
+ let icontext = HscTypes.hsc_IC env
+
+ (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
+ -- Translage the TcRn (typecheck-rename) monad into an IO monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ (tc_expr, insts) <- TcRnMonad.getLIE $ do
+ -- Rename the expression, resulting in a HsExpr Name
+ (rn_expr, freevars) <- RnExpr.rnExpr expr
+ -- Typecheck the expression, resulting in a HsExpr Id and a list of
+ -- Insts
+ (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
+ return res
+ -- Translate the instances into bindings
+ --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
+ binds <- TcSimplify.tcSimplifyTop insts
+ return (binds, tc_expr)
+
+ -- Create a let expression with the extra binds (for polymorphism etc.) and
+ -- the resulting expression.
+ let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
+ (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
+ tc_expr
+ -- Desugar the expression, resulting in core.
+ let rdr_env = HscTypes.ic_rn_gbl_env icontext
+ desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
+
+ return desugar_expr
+
+-- | Create an Id from a RdrName. Might not work for DataCons...
+mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
+mkId rdr_name = do
+ env <- GHC.getSession
+ id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
+ -- Translage the TcRn (typecheck-rename) monad in an IO monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
+ -- Automatically import all available modules, so fully qualified names
+ -- always work
+ TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
+ -- Lookup a Name for the RdrName. This finds the package (version) in
+ -- which the name resides.
+ name <- RnEnv.lookupGlobalOccRn rdr_name
+ -- Lookup an Id for the Name. This finds out the the type of the thing
+ -- we're looking for.
+ --
+ -- Note that tcLookupId doesn't seem to work for DataCons. See source for
+ -- tcLookupId to find out.
+ TcEnv.tcLookupId name
+ return id
+
+normaliseType ::
+ HscTypes.HscEnv
+ -> Type.Type
+ -> IO Type.Type
+normaliseType env ty = do
+ (err, nty) <- MonadUtils.liftIO $
+ -- Initialize the typechecker monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ -- Normalize the type
+ (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
+ return nty
+ let normalized_ty = Maybe.fromJust nty
+ return normalized_ty
+
+-- | Translate a core Type to an HsType. Far from complete so far.
+coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
+-- Translate TyConApps
+coreToHsType ty = case Type.splitTyConApp_maybe ty of
+ Just (tycon, tys) ->
+ foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
+ where
+ tycon_name = TyCon.tyConName tycon
+ mod_name = Module.moduleName $ Name.nameModule tycon_name
+ occ_name = Name.nameOccName tycon_name
+ tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
+ tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+ Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
+
+-- | Evaluate a CoreExpr and return its value. For this to work, the caller
+-- should already know the result type for sure, since the result value is
+-- unsafely coerced into this type.
+execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
+execCore expr = do
+ -- Setup session flags (yeah, this seems like a noop, but
+ -- setSessionDynFlags really does some extra work...)
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ -- Compile the expressions. This runs in the IO monad, but really wants
+ -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
+ -- understand what it means, but it works.
+ env <- GHC.getSession
+ let srcspan = SrcLoc.noSrcSpan
+ hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
+ let res = Unsafe.Coerce.unsafeCoerce hval :: Int
+ return $ Unsafe.Coerce.unsafeCoerce hval
+
+-- These functions build (parts of) a LHSExpr RdrName.
+
+-- | A reference to the Prelude.undefined function.
+hsUndef :: HsExpr.LHsExpr RdrName.RdrName
+hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
+
+-- | A typed reference to the Prelude.undefined function.
+hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
+hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
+
+-- | Create a qualified RdrName from a module name and a variable name
+mkRdrName :: String -> String -> RdrName.RdrName
+mkRdrName mod var =
+ RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
+
+-- These three functions are simplified copies of those in HscMain, because
+-- those functions are not exported. These versions have all error handling
+-- removed.
+hscParseType = hscParseThing Parser.parseType
+hscParseStmt = hscParseThing Parser.parseStmt
+
+hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
+hscParseThing parser dflags str = do
+ buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
+ let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
+ let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
+ return thing
+
+-- | This function imports the module with the given name, for the renamer /
+-- typechecker to use. It also imports any "orphans" and "family instances"
+-- from modules included by this module, but not the actual modules
+-- themselves. I'm not 100% sure how this works, but it seems that any
+-- functions defined in included modules are available just by loading the
+-- original module, and by doing this orphan stuff, any (type family or class)
+-- instances are available as well.
+--
+-- Most of the code is based on tcRnImports and rnImportDecl, but those
+-- functions do a lot more (which I hope we won't need...).
+importModule :: Module.ModuleName -> TcRnTypes.RnM ()
+importModule mod = do
+ let reason = Outputable.text "Hardcoded import" -- Used for trace output
+ let pkg = Nothing
+ -- Load the interface.
+ iface <- LoadIface.loadSrcInterface reason mod False pkg
+ -- Load orphan an familiy instance dependencies as well. I think these
+ -- dependencies are needed for the type checker to know all instances. Any
+ -- other instances (on other packages) are only useful to the
+ -- linker, so we can probably safely ignore them here. Dependencies within
+ -- the same package are also listed in deps, but I'm not so sure what to do
+ -- with them.
+ let deps = HscTypes.mi_deps iface
+ let orphs = HscTypes.dep_orphs deps
+ let finsts = HscTypes.dep_finsts deps
+ LoadIface.loadOrphanModules orphs False
+ LoadIface.loadOrphanModules finsts True
--- /dev/null
+module Pretty (prettyShow, pprString, pprStringDebug) where
+
+
+import qualified Data.Map as Map
+import qualified Data.Foldable as Foldable
+import qualified List
+
+import qualified CoreSyn
+import qualified Module
+import qualified HscTypes
+import Text.PrettyPrint.HughesPJClass
+import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
+
+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
+
+-- | 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) =
+ 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)
+ modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
+{-
+instance Pretty FuncData where
+ pPrint (FuncData flatfunc entity arch) =
+ text "Flattened: " $$ nest 15 (ppffunc flatfunc)
+ $+$ text "Entity" $$ nest 15 (ppent entity)
+ $+$ pparch arch
+ where
+ ppffunc (Just f) = pPrint f
+ ppffunc Nothing = text "Nothing"
+ ppent (Just e) = pPrint e
+ ppent Nothing = text "Nothing"
+ pparch Nothing = text "VHDL architecture not present"
+ pparch (Just _) = text "VHDL architecture present"
+-}
+
+instance Pretty Entity where
+ pPrint (Entity id args res) =
+ text "Entity: " $$ nest 10 (pPrint id)
+ $+$ text "Args: " $$ nest 10 (pPrint args)
+ $+$ text "Result: " $$ nest 10 (pPrint res)
+
+instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
+ pPrint (CoreSyn.NonRec b expr) =
+ text "NonRec: " $$ nest 10 (prettyBind (b, expr))
+ pPrint (CoreSyn.Rec binds) =
+ text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
+
+instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
+ pPrint = text . show
+
+instance Pretty AST.VHDLId where
+ pPrint id = Ppr.ppr id
+
+instance Pretty AST.VHDLName where
+ pPrint name = Ppr.ppr name
+
+prettyBind :: (Show b, Show e) => (b, e) -> Doc
+prettyBind (b, expr) =
+ text b' <> text " = " <> text expr'
+ where
+ b' = show b
+ expr' = show expr
+
+instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
+ pPrint =
+ vcat . map ppentry . Map.toList
+ where
+ ppentry (k, v) =
+ pPrint k <> text " : " $$ nest 15 (pPrint v)
+
+-- Convenience method for turning an Outputable into a string
+pprString :: (Outputable x) => x -> String
+pprString = showSDoc . ppr
+
+pprStringDebug :: (Outputable x) => x -> String
+pprStringDebug = showSDocDebug . ppr
--- /dev/null
+module Constants where
+
+import qualified Language.VHDL.AST as AST
+
+--------------
+-- Identifiers
+--------------
+
+-- | reset and clock signal identifiers in String form
+resetStr, clockStr :: String
+resetStr = "resetn"
+clockStr = "clock"
+
+-- | reset and clock signal identifiers in basic AST.VHDLId form
+resetId, clockId :: AST.VHDLId
+resetId = AST.unsafeVHDLBasicId resetStr
+clockId = AST.unsafeVHDLBasicId clockStr
+
+
+-- | \"types\" identifier
+typesId :: AST.VHDLId
+typesId = AST.unsafeVHDLBasicId "types"
+
+-- | work identifier
+workId :: AST.VHDLId
+workId = AST.unsafeVHDLBasicId "work"
+
+-- | std identifier
+stdId :: AST.VHDLId
+stdId = AST.unsafeVHDLBasicId "std"
+
+
+-- | textio identifier
+textioId :: AST.VHDLId
+textioId = AST.unsafeVHDLBasicId "textio"
+
+-- | range attribute identifier
+rangeId :: AST.VHDLId
+rangeId = AST.unsafeVHDLBasicId "range"
+
+
+-- | high attribute identifier
+highId :: AST.VHDLId
+highId = AST.unsafeVHDLBasicId "high"
+
+-- | range attribute identifier
+imageId :: AST.VHDLId
+imageId = AST.unsafeVHDLBasicId "image"
+
+-- | event attribute identifie
+eventId :: AST.VHDLId
+eventId = AST.unsafeVHDLBasicId "event"
+
+
+-- | default function identifier
+defaultId :: AST.VHDLId
+defaultId = AST.unsafeVHDLBasicId "default"
+
+-- FSVec function identifiers
+
+-- | ex (operator ! in original Haskell source) function identifier
+exId :: String
+exId = "!"
+
+-- | sel (function select in original Haskell source) function identifier
+selId :: String
+selId = "select"
+
+
+-- | ltplus (function (<+) in original Haskell source) function identifier
+ltplusId :: String
+ltplusId = "<+"
+
+
+-- | plusplus (function (++) in original Haskell source) function identifier
+plusplusId :: String
+plusplusId = "++"
+
+
+-- | empty function identifier
+emptyId :: String
+emptyId = "empty"
+
+-- | plusgt (function (+>) in original Haskell source) function identifier
+plusgtId :: String
+plusgtId = "+>"
+
+-- | singleton function identifier
+singletonId :: String
+singletonId = "singleton"
+
+-- | length function identifier
+lengthId :: String
+lengthId = "length"
+
+
+-- | isnull (function null in original Haskell source) function identifier
+nullId :: String
+nullId = "null"
+
+
+-- | replace function identifier
+replaceId :: String
+replaceId = "replace"
+
+
+-- | head function identifier
+headId :: String
+headId = "head"
+
+
+-- | last function identifier
+lastId :: String
+lastId = "last"
+
+
+-- | init function identifier
+initId :: String
+initId = "init"
+
+
+-- | tail function identifier
+tailId :: String
+tailId = "tail"
+
+
+-- | take function identifier
+takeId :: String
+takeId = "take"
+
+
+-- | drop function identifier
+dropId :: String
+dropId = "drop"
+
+-- | shiftl function identifier
+shiftlId :: String
+shiftlId = "shiftl"
+
+-- | shiftr function identifier
+shiftrId :: String
+shiftrId = "shiftr"
+
+-- | rotl function identifier
+rotlId :: String
+rotlId = "rotl"
+
+-- | reverse function identifier
+rotrId :: String
+rotrId = "rotr"
+
+-- | concatenate the vectors in a vector
+concatId :: String
+concatId = "concat"
+
+-- | reverse function identifier
+reverseId :: String
+reverseId = "reverse"
+
+-- | iterate function identifier
+iterateId :: String
+iterateId = "iterate"
+
+-- | iteraten function identifier
+iteratenId :: String
+iteratenId = "iteraten"
+
+-- | iterate function identifier
+generateId :: String
+generateId = "generate"
+
+-- | iteraten function identifier
+generatenId :: String
+generatenId = "generaten"
+
+-- | copy function identifier
+copyId :: String
+copyId = "copy"
+
+-- | copyn function identifier
+copynId :: String
+copynId = "copyn"
+
+-- | map function identifier
+mapId :: String
+mapId = "map"
+
+-- | zipwith function identifier
+zipWithId :: String
+zipWithId = "zipWith"
+
+-- | foldl function identifier
+foldlId :: String
+foldlId = "foldl"
+
+-- | foldr function identifier
+foldrId :: String
+foldrId = "foldr"
+
+-- | zip function identifier
+zipId :: String
+zipId = "zip"
+
+-- | unzip function identifier
+unzipId :: String
+unzipId = "unzip"
+
+-- | hwxor function identifier
+hwxorId :: String
+hwxorId = "hwxor"
+
+-- | hwor function identifier
+hworId :: String
+hworId = "hwor"
+
+-- | hwnot function identifier
+hwnotId :: String
+hwnotId = "hwnot"
+
+-- | hwand function identifier
+hwandId :: String
+hwandId = "hwand"
+
+lengthTId :: String
+lengthTId = "lengthT"
+
+-- Numeric Operations
+
+-- | plus operation identifier
+plusId :: String
+plusId = "+"
+
+-- | times operation identifier
+timesId :: String
+timesId = "*"
+
+-- | negate operation identifier
+negateId :: String
+negateId = "negate"
+
+-- | minus operation identifier
+minusId :: String
+minusId = "-"
+
+-- | convert sizedword to ranged
+fromSizedWordId :: String
+fromSizedWordId = "fromSizedWord"
+
+toIntegerId :: String
+toIntegerId = "to_integer"
+
+fromIntegerId :: String
+fromIntegerId = "fromInteger"
+
+toSignedId :: String
+toSignedId = "to_signed"
+
+toUnsignedId :: String
+toUnsignedId = "to_unsigned"
+
+resizeId :: String
+resizeId = "resize"
+
+------------------
+-- VHDL type marks
+------------------
+
+-- | The Bit type mark
+bitTM :: AST.TypeMark
+bitTM = AST.unsafeVHDLBasicId "Bit"
+
+-- | Stardard logic type mark
+std_logicTM :: AST.TypeMark
+std_logicTM = AST.unsafeVHDLBasicId "std_logic"
+
+-- | boolean type mark
+booleanTM :: AST.TypeMark
+booleanTM = AST.unsafeVHDLBasicId "boolean"
+
+-- | fsvec_index AST. TypeMark
+tfvec_indexTM :: AST.TypeMark
+tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
+
+-- | natural AST. TypeMark
+naturalTM :: AST.TypeMark
+naturalTM = AST.unsafeVHDLBasicId "natural"
+
+-- | integer TypeMark
+integerTM :: AST.TypeMark
+integerTM = AST.unsafeVHDLBasicId "integer"
+
+-- | signed TypeMark
+signedTM :: AST.TypeMark
+signedTM = AST.unsafeVHDLBasicId "signed"
+
+-- | unsigned TypeMark
+unsignedTM :: AST.TypeMark
+unsignedTM = AST.unsafeVHDLBasicId "unsigned"
--- /dev/null
+{-# LANGUAGE PackageImports #-}
+
+module Generate where
+
+-- Standard modules
+import qualified Control.Monad as Monad
+import qualified Data.Map as Map
+import qualified Maybe
+import qualified Data.Either as Either
+import qualified Control.Monad.Trans.State as State
+import qualified "transformers" Control.Monad.Identity as Identity
+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 Type
+import qualified Var
+import qualified IdInfo
+import qualified Literal
+import qualified Name
+import qualified TyCon
+
+-- Local imports
+import Constants
+import VHDLTypes
+import VHDLTools
+import CoreTools
+import Pretty
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL for builtin functions
+-----------------------------------------------------------------------------
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be expressions.
+genExprArgs wrap dst func args = do
+ args' <- eitherCoreOrExprArgs args
+ wrap dst func args'
+
+eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
+eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be variables.
+genVarArgs ::
+ (dst -> func -> [Var.Var] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genVarArgs wrap dst func args = wrap dst func args'
+ where
+ args' = map exprToVar exprargs
+ -- Check (rather crudely) that all arguments are CoreExprs
+ (exprargs, []) = Either.partitionEithers args
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be Literals
+genLitArgs ::
+ (dst -> func -> [Literal.Literal] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genLitArgs wrap dst func args = wrap dst func args'
+ where
+ args' = map exprToLit litargs
+ -- FIXME: Check if we were passed an CoreSyn.App
+ litargs = concat (map getLiterals exprargs)
+ (exprargs, []) = Either.partitionEithers args
+
+-- | A function to wrap a builder-like function that produces an expression
+-- and expects it to be assigned to the destination.
+genExprRes ::
+ ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
+ -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
+genExprRes wrap dst func args = do
+ expr <- wrap dst func args
+ return $ [mkUncondAssign dst expr]
+
+-- | Generate a binary operator application. The first argument should be a
+-- constructor from the AST.Expr type, e.g. AST.And.
+genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
+genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
+
+-- | Generate a unary operator application
+genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
+genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genOperator1' op _ f [arg] = return $ op arg
+
+-- | Generate a unary operator application
+genNegation :: BuiltinBuilder
+genNegation = genVarArgs $ genExprRes genNegation'
+genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation' _ f [arg] = do
+ arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
+ let ty = Var.varType arg
+ let (tycon, args) = Type.splitTyConApp ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "SizedInt" -> return $ AST.Neg arg1
+ otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
+
+-- | Generate a function call from the destination binder, function name and a
+-- list of expressions (its arguments)
+genFCall :: Bool -> BuiltinBuilder
+genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFCall' switch (Left res) f args = do
+ let fname = varToString f
+ let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
+ id <- MonadState.lift vsType $ vectorFunId el_ty fname
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genFromSizedWord :: BuiltinBuilder
+genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFromSizedWord' (Left res) f args = do
+ let fname = varToString f
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genResize :: BuiltinBuilder
+genResize = genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genResize' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+-- FIXME: I'm calling genLitArgs which is very specific function,
+-- which needs to be fixed as well
+genFromInteger :: BuiltinBuilder
+genFromInteger = genLitArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
+genFromInteger' (Left res) f lits = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+ ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+
+genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+
+-- | Generate a generate statement for the builtin function "map"
+genMap :: BuiltinBuilder
+genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
+ -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
+ -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
+ -- we must index it (which we couldn't if it was a VHDL Expr, since only
+ -- VHDLNames can be indexed).
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args
+ } ;
+ ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
+ -- Return the generate statement
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ }
+
+genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
+
+genZipWith :: BuiltinBuilder
+genZipWith = genVarArgs genZipWith'
+genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the zipped_f to
+ -- each of the elements in arg1 and arg2, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ }
+
+genFoldl :: BuiltinBuilder
+genFoldl = genFold True
+
+genFoldr :: BuiltinBuilder
+genFoldr = genFold False
+
+genFold :: Bool -> BuiltinBuilder
+genFold left = genVarArgs (genFold' left)
+
+genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genFold' left res f args@[folded_f , start ,vec]= do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
+ genFold'' len left res f args
+
+genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+-- Special case for an empty input vector, just assign start to res
+genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
+ arg <- MonadState.lift vsType $ varToVHDLExpr start
+ return [mkUncondAssign (Left res) arg]
+
+genFold'' len left (Left res) f [folded_f, start, vec] = do
+ -- The vector length
+ --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
+ -- evec is (TFVec n), so it still needs an element type
+ let (nvec, _) = splitAppTy (Var.varType vec)
+ -- Put the type of the start value in nvec, this will be the type of our
+ -- temporary vector
+ let tmp_ty = Type.mkAppTy nvec (Var.varType start)
+ let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
+ tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
+ let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
+ else AST.DownRange len_min_expr (AST.PrimLit "0")
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells <- sequence [genFirstCell, genOtherCell]
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
+ (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
+ (mkIndexedName tmp_name (AST.PrimLit "0")))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return [AST.CSBSm block]
+ where
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
+ else (n_cur AST.:+: (AST.PrimLit "1"))
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell = do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ app_concsms <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+ genOtherCell = do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ app_concsms <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+-- | Generate a generate statement for the builtin function "zip"
+genZip :: BuiltinBuilder
+genZip = genVarArgs genZip'
+genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genZip' (Left res) f args@[arg1, arg2] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
+ ; let { resnameA = mkSelectedName resname' (labels!!0)
+ ; resnameB = mkSelectedName resname' (labels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
+ ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
+ } ;
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
+
+-- | Generate a generate statement for the builtin function "unzip"
+genUnzip :: BuiltinBuilder
+genUnzip = genVarArgs genUnzip'
+genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genUnzip' (Left res) f args@[arg] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = varToVHDLName res
+ ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
+ } ;
+ ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
+ ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+ ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+ ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexprA
+ ; resB_assign = mkUncondAssign (Right resnameB) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
+
+genCopy :: BuiltinBuilder
+genCopy = genVarArgs genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genCopy' (Left res) f args@[arg] =
+ let
+ resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ (varToVHDLName arg))]
+ out_assign = mkUncondAssign (Left res) resExpr
+ in
+ return [out_assign]
+
+genConcat :: BuiltinBuilder
+genConcat = genVarArgs genConcat'
+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genConcat' (Left res) f args@[arg] = do {
+ -- Setup the generate scheme
+ ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ ; let (_, nvec) = splitAppTy (Var.varType arg)
+ ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
+ ; resname = vecSlice fromRange toRange
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; out_assign = mkUncondAssign (Right resname) argexpr
+ } ;
+ -- Return the generate statement
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+ }
+ where
+ vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
+ (AST.ToRange init last))
+
+genIteraten :: BuiltinBuilder
+genIteraten dst f args = genIterate dst f (tail args)
+
+genIterate :: BuiltinBuilder
+genIterate = genIterateOrGenerate True
+
+genGeneraten :: BuiltinBuilder
+genGeneraten dst f args = genGenerate dst f (tail args)
+
+genGenerate :: BuiltinBuilder
+genGenerate = genIterateOrGenerate False
+
+genIterateOrGenerate :: Bool -> BuiltinBuilder
+genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
+
+genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate' iter (Left res) f args = do
+ len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ genIterateOrGenerate'' len iter (Left res) f args
+
+genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+-- Special case for an empty input vector, just assign start to res
+genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+
+genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
+ -- The vector length
+ -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
+ -- -- evec is (TFVec n), so it still needs an element type
+ -- let (nvec, _) = splitAppTy (Var.varType vec)
+ -- -- Put the type of the start value in nvec, this will be the type of our
+ -- -- temporary vector
+ let tmp_ty = Var.varType res
+ let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
+ tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
+ let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
+ let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells <- sequence [genFirstCell, genOtherCell]
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return [AST.CSBSm block]
+ where
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = n_cur AST.:-: (AST.PrimLit "1")
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell = do
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ argexpr <- MonadState.lift vsType $ varToVHDLExpr start
+ let startassign = mkUncondAssign (Right resname) argexpr
+ app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
+ [startassign]
+ else
+ app_concsms
+ )
+
+ genOtherCell = do
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+
+-----------------------------------------------------------------------------
+-- Function to generate VHDL for applications
+-----------------------------------------------------------------------------
+genApplication ::
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
+ -> CoreSyn.CoreBndr -- ^ The function to apply
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
+ -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
+genApplication dst f args = 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.
+ case (Map.lookup f signatures) of
+ Just signature -> do
+ args' <- eitherCoreOrExprArgs args
+ -- We have a signature, this is a top level binding. Generate a
+ -- component instantiation.
+ let entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ let label = "comp_ins_" ++ (either show prettyShow) dst
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ return [mkComponentInst label entity_id portmaps]
+ Nothing -> do
+ -- No signature, so this must be a local variable reference. It
+ -- should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an
+ -- unconditional assignment here.
+ f' <- MonadState.lift vsType $ varToVHDLExpr f
+ return $ [mkUncondAssign dst f']
+ 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.
+-----------------------------------------------------------------------------
+
+-- Returns the VHDLId of the vector function with the given name for the given
+-- element type. Generates -- this function if needed.
+vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
+vectorFunId el_ty fname = do
+ let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
+ elemTM <- vhdl_ty error_msg el_ty
+ -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
+ -- the VHDLState or something.
+ let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
+ typefuns <- getA vsTypeFuns
+ case Map.lookup (OrdType el_ty, fname) typefuns of
+ -- Function already generated, just return it
+ Just (id, _) -> return id
+ -- Function not generated yet, generate it
+ Nothing -> do
+ let functions = genUnconsVectorFuns elemTM vectorTM
+ case lookup fname functions of
+ Just body -> do
+ modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+ mapM_ (vectorFunId el_ty) (snd body)
+ return function_id
+ Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
+ where
+ function_id = mkVHDLExtId fname
+
+genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
+ -> AST.TypeMark -- ^ type of the vector
+ -> [(String, (AST.SubProgBody, [String]))]
+genUnconsVectorFuns elemTM vectorTM =
+ [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
+ , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
+ , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
+ , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
+ , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
+ , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
+ , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
+ , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
+ , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
+ , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
+ , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
+ , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
+ , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
+ , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
+ , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
+ , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
+ , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+ , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+ , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
+ , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
+ , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
+ , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
+ ]
+ where
+ ixPar = AST.unsafeVHDLBasicId "ix"
+ vecPar = AST.unsafeVHDLBasicId "vec"
+ vec1Par = AST.unsafeVHDLBasicId "vec1"
+ vec2Par = AST.unsafeVHDLBasicId "vec2"
+ nPar = AST.unsafeVHDLBasicId "n"
+ iId = AST.unsafeVHDLBasicId "i"
+ iPar = iId
+ aPar = AST.unsafeVHDLBasicId "a"
+ fPar = AST.unsafeVHDLBasicId "f"
+ sPar = AST.unsafeVHDLBasicId "s"
+ resId = AST.unsafeVHDLBasicId "res"
+ exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec ixPar naturalTM] elemTM
+ exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
+ (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
+ AST.NSimple ixPar]))
+ replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
+ , AST.IfaceVarDec iPar naturalTM
+ , AST.IfaceVarDec aPar elemTM
+ ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ replaceVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
+ replaceExpr = AST.NSimple resId AST.:=
+ (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
+ AST.PrimName (AST.NSimple aPar) AST.:&:
+ vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
+ ((AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+ AST.:-: AST.PrimLit "1"))
+ replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ vecSlice init last = AST.PrimName (AST.NSlice
+ (AST.SliceName
+ (AST.NSimple vecPar)
+ (AST.ToRange init last)))
+ headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(0);
+ headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar) [AST.PrimLit "0"])))
+ lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(vec'length-1);
+ lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar)
+ [AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"])))
+ initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ initVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- resAST.:= vec(0 to vec'length-2)
+ initExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "2"))
+ initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ tailVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- res AST.:= vec(1 to vec'length-1)
+ tailExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "1")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"))
+ tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1);
+ takeVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to n-1)
+ takeExpr = AST.NSimple resId AST.:=
+ (vecSlice (AST.PrimLit "1")
+ (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
+ takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-n-1);
+ dropVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(n to vec'length-1)
+ dropExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimName $ AST.NSimple nPar)
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"))
+ dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
+ AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length);
+ plusgtVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
+ Nothing
+ plusgtExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple aPar) AST.:&:
+ (AST.PrimName $ AST.NSimple vecPar))
+ plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
+ emptyVar =
+ AST.ConstDec resId
+ (AST.SubtypeIn vectorTM Nothing)
+ (Just $ AST.PrimLit "\"\"")
+ emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+ singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
+ vectorTM
+ -- variable res : fsvec_x (0 to 0) := (others => a);
+ singletonVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
+ (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ AST.NSimple aPar)])
+ singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1) := (others => a);
+ copynVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ]))
+ (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ AST.NSimple aPar)])
+ -- return res
+ copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
+ AST.IfaceVarDec sPar naturalTM,
+ AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1);
+ selVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ])
+ )
+ Nothing
+ -- for i res'range loop
+ -- res(i) := vec(f+i*s);
+ -- end loop;
+ selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
+ -- res(i) := vec(f+i*s);
+ selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
+ (AST.PrimName (AST.NSimple iId) AST.:*:
+ AST.PrimName (AST.NSimple sPar)) in
+ AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
+ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
+ -- return res;
+ selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+ ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length);
+ ltplusVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
+ Nothing
+ ltplusExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
+ (AST.PrimName $ AST.NSimple aPar))
+ ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
+ AST.IfaceVarDec vec2Par vectorTM]
+ vectorTM
+ -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
+ plusplusVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
+ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.PrimLit "1")]))
+ Nothing
+ plusplusExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
+ (AST.PrimName $ AST.NSimple vec2Par))
+ plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
+ lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+ shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftlVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res := a & init(vec)
+ shiftlExpr = AST.NSimple resId AST.:=
+ (AST.PrimName (AST.NSimple aPar) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftrVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res := tail(vec) & a
+ shiftrExpr = AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimName (AST.NSimple aPar)))
+
+ shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
+ -- return vec'length = 0
+ nullExpr = AST.ReturnSm (Just $
+ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
+ AST.PrimLit "0")
+ rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotlVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- if null(vec) then res := vec else res := last(vec) & init(vec)
+ rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotlExprRet])
+ where rotlExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotrVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- if null(vec) then res := vec else res := tail(vec) & head(vec)
+ rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotrExprRet])
+ where rotrExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ reverseVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- for i in 0 to res'range loop
+ -- res(vec'length-i-1) := vec(i);
+ -- end loop;
+ reverseFor =
+ AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
+ -- res(vec'length-i-1) := vec(i);
+ reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
+ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
+ [AST.PrimName $ AST.NSimple iId]))
+ where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
+ (mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.PrimName (AST.NSimple iId) AST.:-:
+ (AST.PrimLit "1")
+ -- return res;
+ reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+
+-----------------------------------------------------------------------------
+-- A table of builtin functions
+-----------------------------------------------------------------------------
+
+-- | The builtin functions we support. Maps a name to an argument count and a
+-- builder function.
+globalNameTable :: NameTable
+globalNameTable = Map.fromList
+ [ (exId , (2, genFCall False ) )
+ , (replaceId , (3, genFCall False ) )
+ , (headId , (1, genFCall True ) )
+ , (lastId , (1, genFCall True ) )
+ , (tailId , (1, genFCall False ) )
+ , (initId , (1, genFCall False ) )
+ , (takeId , (2, genFCall False ) )
+ , (dropId , (2, genFCall False ) )
+ , (selId , (4, genFCall False ) )
+ , (plusgtId , (2, genFCall False ) )
+ , (ltplusId , (2, genFCall False ) )
+ , (plusplusId , (2, genFCall False ) )
+ , (mapId , (2, genMap ) )
+ , (zipWithId , (3, genZipWith ) )
+ , (foldlId , (3, genFoldl ) )
+ , (foldrId , (3, genFoldr ) )
+ , (zipId , (2, genZip ) )
+ , (unzipId , (1, genUnzip ) )
+ , (shiftlId , (2, genFCall False ) )
+ , (shiftrId , (2, genFCall False ) )
+ , (rotlId , (1, genFCall False ) )
+ , (rotrId , (1, genFCall False ) )
+ , (concatId , (1, genConcat ) )
+ , (reverseId , (1, genFCall False ) )
+ , (iteratenId , (3, genIteraten ) )
+ , (iterateId , (2, genIterate ) )
+ , (generatenId , (3, genGeneraten ) )
+ , (generateId , (2, genGenerate ) )
+ , (emptyId , (0, genFCall False ) )
+ , (singletonId , (1, genFCall False ) )
+ , (copynId , (2, genFCall False ) )
+ , (copyId , (1, genCopy ) )
+ , (lengthTId , (1, genFCall False ) )
+ , (nullId , (1, genFCall False ) )
+ , (hwxorId , (2, genOperator2 AST.Xor ) )
+ , (hwandId , (2, genOperator2 AST.And ) )
+ , (hworId , (2, genOperator2 AST.Or ) )
+ , (hwnotId , (1, genOperator1 AST.Not ) )
+ , (plusId , (2, genOperator2 (AST.:+:) ) )
+ , (timesId , (2, genOperator2 (AST.:*:) ) )
+ , (negateId , (1, genNegation ) )
+ , (minusId , (2, genOperator2 (AST.:-:) ) )
+ , (fromSizedWordId , (1, genFromSizedWord ) )
+ , (fromIntegerId , (1, genFromInteger ) )
+ , (resizeId , (1, genResize ) )
+ ]
--- /dev/null
+--
+-- Functions to generate VHDL from FlatFunctions
+--
+module VHDL where
+
+-- Standard modules
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Maybe
+import qualified Control.Monad as Monad
+import qualified Control.Arrow as Arrow
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Monoid as Monoid
+import Data.Accessor
+import Data.Accessor.MonadState as MonadState
+import Debug.Trace
+
+-- ForSyDe
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import CoreSyn
+--import qualified Type
+import qualified Name
+import qualified Var
+import qualified Id
+import qualified IdInfo
+import qualified TyCon
+import qualified DataCon
+--import qualified CoreSubst
+import qualified CoreUtils
+import Outputable ( showSDoc, ppr )
+
+-- Local imports
+import VHDLTypes
+import VHDLTools
+import Pretty
+import CoreTools
+import Constants
+import Generate
+
+createDesignFiles ::
+ TypeState
+ -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ -> [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles init_typestate binds =
+ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
+ map (Arrow.second $ AST.DesignFile full_context) units
+
+ where
+ init_session = VHDLState init_typestate Map.empty
+ (units, final_session) =
+ State.runState (createLibraryUnits binds) init_session
+ tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
+ ty_decls = final_session ^. vsType ^. vsTypeDecls
+ tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+ tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
+ tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+ ieee_context = [
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"]
+ ]
+ full_context =
+ mkUseAll ["work", "types"]
+ : (mkUseAll ["work"]
+ : ieee_context)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ subProgSpecs = map subProgSpec tyfun_decls
+ subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
+
+-- Create a use foo.bar.all statement. Takes a list of components in the used
+-- name. Must contain at least two components
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss =
+ AST.Use $ from AST.:.: AST.All
+ where
+ base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+ from = foldl select base_prefix (tail ss)
+ select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+
+createLibraryUnits ::
+ [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
+
+createLibraryUnits binds = do
+ entities <- Monad.mapM createEntity binds
+ archs <- Monad.mapM createArchitecture binds
+ return $ zipWith
+ (\ent arch ->
+ let AST.EntityDec id _ = ent in
+ (id, [AST.LUEntity ent, AST.LUArch arch])
+ )
+ entities archs
+
+-- | Create an entity for a given function
+createEntity ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
+ -> VHDLSession AST.EntityDec -- | The resulting entity
+
+createEntity (fname, expr) = do
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ args' <- Monad.mapM mkMap args
+ -- There must be a let at top level
+ let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
+ res' <- mkMap res
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+ let ent_decl' = createEntityAST vhdl_id args' res'
+ let AST.EntityDec entity_id _ = ent_decl'
+ let signature = Entity entity_id args' res'
+ modA vsSignatures (Map.insert fname signature)
+ return ent_decl'
+ where
+ mkMap ::
+ --[(SignalId, SignalInfo)]
+ CoreSyn.CoreBndr
+ -> VHDLSession Port
+ -- We only need the vsTypes element from the state
+ mkMap = (\bndr ->
+ let
+ --info = Maybe.fromMaybe
+ -- (error $ "Signal not found in the name map? This should not happen!")
+ -- (lookup id sigmap)
+ -- Assume the bndr has a valid VHDL id already
+ id = varToVHDLId bndr
+ ty = Var.varType bndr
+ error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
+ in do
+ type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
+ return (id, type_mark)
+ )
+
+ -- | Create the VHDL AST for an entity
+createEntityAST ::
+ AST.VHDLId -- | The name of the function
+ -> [Port] -- | The entity's arguments
+ -> Port -- | The entity's result
+ -> AST.EntityDec -- | The entity with the ent_decl filled in as well
+
+createEntityAST vhdl_id args res =
+ AST.EntityDec vhdl_id ports
+ where
+ -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
+ ports = map (mkIfaceSigDec AST.In) args
+ ++ [mkIfaceSigDec AST.Out res]
+ ++ [clk_port]
+ -- Add a clk port if we have state
+ clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
+
+-- | Create a port declaration
+mkIfaceSigDec ::
+ AST.Mode -- | The mode for the port (In / Out)
+ -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
+ -> AST.IfaceSigDec -- | The resulting port declaration
+
+mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
+
+{-
+-- | Generate a VHDL entity name for the given hsfunc
+mkEntityId hsfunc =
+ -- TODO: This doesn't work for functions with multiple signatures!
+ -- Use a Basic Id, since using extended id's for entities throws off
+ -- precision and causes problems when generating filenames.
+ mkVHDLBasicId $ hsFuncName hsfunc
+-}
+
+-- | Create an architecture for a given function
+createArchitecture ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
+ -> VHDLSession AST.ArchBody -- ^ The architecture for this function
+
+createArchitecture (fname, expr) = do
+ signaturemap <- getA vsSignatures
+ let signature = Maybe.fromMaybe
+ (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
+ (Map.lookup fname signaturemap)
+ let entity_id = ent_id signature
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ -- There must be a let at top level
+ let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
+
+ -- Create signal declarations for all binders in the let expression, except
+ -- for the output port (that will already have an output port declared in
+ -- the entity).
+ sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
+ let sig_decs = Maybe.catMaybes $ sig_dec_maybes
+
+ statementss <- Monad.mapM mkConcSm binds
+ let statements = concat statementss
+ return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+ where
+ procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
+ procs' = map AST.CSPSm procs
+ -- mkSigDec only uses vsTypes from the state
+ mkSigDec' = mkSigDec
+
+{-
+-- | Looks up all pairs of old state, new state signals, together with
+-- the state id they represent.
+makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
+makeStatePairs flatfunc =
+ [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
+ | old_info <- map snd (flat_sigs flatfunc)
+ , new_info <- map snd (flat_sigs flatfunc)
+ -- old_info must be an old state (and, because of the next equality,
+ -- new_info must be a new state).
+ , Maybe.isJust $ oldStateId $ sigUse old_info
+ -- And the state numbers must match
+ , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
+
+ -- Replace the second tuple element with the corresponding SignalInfo
+ --args_states = map (Arrow.second $ signalInfo sigs) args
+mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
+mkStateProcSm (num, old, new) =
+ AST.ProcSm label [clk] [statement]
+ where
+ label = mkVHDLExtId $ "state_" ++ (show num)
+ clk = mkVHDLExtId "clk"
+ rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+ wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
+ assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
+ rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
+ statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+
+-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
+-- is not named.
+getSignalId :: SignalInfo -> AST.VHDLId
+getSignalId info =
+ mkVHDLExtId $ Maybe.fromMaybe
+ (error $ "Unnamed signal? This should not happen!")
+ (sigName info)
+-}
+
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
+mkSigDec bndr =
+ if True then do --isInternalSigUse use || isStateSigUse use then do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
+ return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ else
+ return Nothing
+
+-- | Transforms a core binding into a VHDL concurrent statement
+mkConcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+ -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
+
+-- Simple a = b assignments are just like applications, but without arguments.
+-- We can't just generate an unconditional assignment here, since b might be a
+-- top level binding (e.g., a function with no arguments).
+mkConcSm (bndr, Var v) = do
+ genApplication (Left bndr) v []
+
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ genApplication (Left bndr) f (map Left valargs)
+
+-- A single alt case must be a selector. This means thee scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
+ case alt of
+ (DataAlt dc, bndrs, (Var sel_bndr)) -> do
+ case List.elemIndex sel_bndr bndrs of
+ Just i -> do
+ labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
+ let label = labels!!i
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
+ let sel_expr = AST.PrimName sel_name
+ return [mkUncondAssign (Left bndr) sel_expr]
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
+ scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
+ let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+ true_expr <- MonadState.lift vsType $ varToVHDLExpr true
+ false_expr <- MonadState.lift vsType $ varToVHDLExpr false
+ return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
--- /dev/null
+module VHDLTools where
+
+-- Standard modules
+import qualified Maybe
+import qualified Data.Either as Either
+import qualified Data.List as List
+import qualified Data.Map as Map
+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 Debug.Trace
+
+-- ForSyDe
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import CoreSyn
+import qualified Name
+import qualified OccName
+import qualified Var
+import qualified Id
+import qualified IdInfo
+import qualified TyCon
+import qualified Type
+import qualified DataCon
+import qualified CoreSubst
+
+-- Local imports
+import VHDLTypes
+import CoreTools
+import Pretty
+import Constants
+
+-----------------------------------------------------------------------------
+-- Functions to generate concurrent statements
+-----------------------------------------------------------------------------
+
+-- Create an unconditional assignment statement
+mkUncondAssign ::
+ Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> AST.Expr -- ^ The expression to assign
+ -> AST.ConcSm -- ^ The resulting concurrent statement
+mkUncondAssign dst expr = mkAssign dst Nothing expr
+
+-- Create a conditional assignment statement
+mkCondAssign ::
+ Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> AST.Expr -- ^ The condition
+ -> AST.Expr -- ^ The value when true
+ -> AST.Expr -- ^ The value when false
+ -> AST.ConcSm -- ^ The resulting concurrent statement
+mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
+
+-- Create a conditional or unconditional assignment statement
+mkAssign ::
+ Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
+ Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
+ -- and the value to assign when true.
+ AST.Expr -> -- ^ The value to assign when false or no condition
+ AST.ConcSm -- ^ The resulting concurrent statement
+mkAssign dst cond false_expr =
+ let
+ -- I'm not 100% how this assignment AST works, but this gets us what we
+ -- want...
+ whenelse = case cond of
+ Just (cond_expr, true_expr) ->
+ let
+ true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+ in
+ [AST.WhenElse true_wform cond_expr]
+ Nothing -> []
+ false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+ dst_name = case dst of
+ Left bndr -> AST.NSimple (varToVHDLId bndr)
+ Right name -> name
+ assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
+ in
+ AST.CSSASm assign
+
+mkAssocElems ::
+ [AST.Expr] -- | The argument that are applied to function
+ -> AST.VHDLName -- | The binder in which to store the result
+ -> Entity -- | The entity to map against.
+ -> [AST.AssocElem] -- | The resulting port maps
+mkAssocElems args res entity =
+ -- Create the actual AssocElems
+ zipWith mkAssocElem ports sigs
+ where
+ -- Turn the ports and signals from a map into a flat list. This works,
+ -- since the maps must have an identical form by definition. TODO: Check
+ -- the similar form?
+ arg_ports = ent_args entity
+ res_port = ent_res entity
+ -- Extract the id part from the (id, type) tuple
+ ports = map fst (res_port : arg_ports)
+ -- Translate signal numbers into names
+ sigs = (vhdlNameToVHDLExpr res : args)
+
+-- | Create an VHDL port -> signal association
+mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
+mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
+
+-- | Create an VHDL port -> signal association
+mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
+mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
+ (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
+
+mkComponentInst ::
+ String -- ^ The portmap label
+ -> AST.VHDLId -- ^ The entity name
+ -> [AST.AssocElem] -- ^ The port assignments
+ -> AST.ConcSm
+mkComponentInst label entity_id portassigns = AST.CSISm compins
+ where
+ -- We always have a clock port, so no need to map it anywhere but here
+ clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL Exprs
+-----------------------------------------------------------------------------
+
+varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
+varToVHDLExpr var = do
+ case Id.isDataConWorkId_maybe var of
+ Just dc -> return $ dataconToVHDLExpr dc
+ -- This is a dataconstructor.
+ -- Not a datacon, just another signal. Perhaps we should check for
+ -- local/global here as well?
+ -- Sadly so.. tfp decimals are types, not data constructors, but instances
+ -- should still be translated to integer literals. It is probebly not the
+ -- best solution to translate them here.
+ -- FIXME: Find a better solution for translating instances of tfp integers
+ Nothing -> do
+ let ty = Var.varType var
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) ->
+ case Name.getOccString (TyCon.tyConName tycon) of
+ "Dec" -> do
+ len <- tfp_to_int ty
+ return $ AST.PrimLit $ (show len)
+ otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
+
+-- Turn a VHDLName into an AST expression
+vhdlNameToVHDLExpr = AST.PrimName
+
+-- Turn a VHDL Id into an AST expression
+idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
+
+-- Turn a Core expression into an AST expression
+exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
+
+-- Turn a alternative constructor into an AST expression. For
+-- dataconstructors, this is only the constructor itself, not any arguments it
+-- has. Should not be called with a DEFAULT constructor.
+altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
+
+altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+
+-- Turn a datacon (without arguments!) into a VHDL expression.
+dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
+dataconToVHDLExpr dc = AST.PrimLit lit
+ where
+ tycon = DataCon.dataConTyCon dc
+ tyname = TyCon.tyConName tycon
+ dcname = DataCon.dataConName dc
+ lit = case Name.getOccString tyname of
+ -- TODO: Do something more robust than string matching
+ "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+ "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+
+-----------------------------------------------------------------------------
+-- Functions dealing with names, variables and ids
+-----------------------------------------------------------------------------
+
+-- Creates a VHDL Id from a binder
+varToVHDLId ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLId
+varToVHDLId = mkVHDLExtId . varToString
+
+-- Creates a VHDL Name from a binder
+varToVHDLName ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLName
+varToVHDLName = AST.NSimple . varToVHDLId
+
+-- Extracts the binder name as a String
+varToString ::
+ CoreSyn.CoreBndr
+ -> String
+varToString = OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Get the string version a Var's unique
+varToStringUniq :: Var.Var -> String
+varToStringUniq = show . Var.varUnique
+
+-- Extracts the string version of the name
+nameToString :: Name.Name -> String
+nameToString = OccName.occNameString . Name.nameOccName
+
+-- Shortcut for Basic VHDL Ids.
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s =
+ AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
+ where
+ -- Strip invalid characters.
+ strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
+ -- Strip leading numbers and underscores
+ strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
+ -- Strip multiple adjacent underscores
+ strip_multiscore = concat . map (\cs ->
+ case cs of
+ ('_':_) -> "_"
+ _ -> cs
+ ) . List.group
+
+-- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
+-- different characters than basic ids, but can never be used to refer to
+-- basic ids.
+-- Use extended Ids for any values that are taken from the source file.
+mkVHDLExtId :: String -> AST.VHDLId
+mkVHDLExtId s =
+ AST.unsafeVHDLExtId $ strip_invalid s
+ where
+ -- Allowed characters, taken from ForSyde's mkVHDLExtId
+ allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+ strip_invalid = filter (`elem` allowed)
+
+-- Create a record field selector that selects the given label from the record
+-- stored in the given binder.
+mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
+mkSelectedName name label =
+ AST.NSelected $ name AST.:.: (AST.SSimple label)
+
+-- Create an indexed name that selects a given element from a vector.
+mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
+-- Special case for already indexed names. Just add an index
+mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
+ AST.NIndexed (AST.IndexedName name (indexes++[index]))
+-- General case for other names
+mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
+
+-----------------------------------------------------------------------------
+-- Functions dealing with VHDL types
+-----------------------------------------------------------------------------
+
+-- | Maps the string name (OccName) of a type to the corresponding VHDL type,
+-- for a few builtin types.
+builtin_types =
+ Map.fromList [
+ ("Bit", std_logicTM),
+ ("Bool", booleanTM), -- TysWiredIn.boolTy
+ ("Dec", integerTM)
+ ]
+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns an error value, using the given message, when no type could be
+-- created.
+vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
+vhdl_ty msg ty = do
+ tm_either <- vhdl_ty_either ty
+ case tm_either of
+ Right tm -> return tm
+ Left err -> error $ msg ++ "\n" ++ err
+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns either an error message or the resulting type.
+vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
+vhdl_ty_either ty = do
+ typemap <- getA vsTypes
+ htype_either <- mkHType ty
+ case htype_either of
+ -- No errors
+ Right htype -> do
+ let builtin_ty = do -- See if this is a tycon and lookup its name
+ (tycon, args) <- Type.splitTyConApp_maybe ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ Map.lookup name builtin_types
+ -- If not a builtin type, try the custom types
+ let existing_ty = (fmap fst) $ Map.lookup htype typemap
+ case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+ -- Found a type, return it
+ Just t -> return (Right t)
+ -- No type yet, try to construct it
+ Nothing -> do
+ newty_maybe <- (construct_vhdl_ty ty)
+ case newty_maybe of
+ Right (ty_id, ty_def) -> do
+ -- TODO: Check name uniqueness
+ modA vsTypes (Map.insert htype (ty_id, ty_def))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return (Right ty_id)
+ Left err -> return $ Left $
+ "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+ ++ err
+ -- Error when constructing htype
+ Left err -> return $ Left err
+
+-- Construct a new VHDL type for the given Haskell type. Returns an error
+-- message or the resulting typemark and typedef.
+construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty ty = do
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "TFVec" -> mk_vector_ty ty
+ "SizedWord" -> mk_unsigned_ty ty
+ "SizedInt" -> mk_signed_ty ty
+ "RangedWord" -> do
+ bound <- tfp_to_int (ranged_word_bound_ty ty)
+ mk_natural_ty 0 bound
+ -- Create a custom type from this tycon
+ otherwise -> mk_tycon_ty tycon args
+ Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
+
+-- | Create VHDL type for a custom tycon
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty tycon args =
+ case TyCon.tyConDataCons tycon of
+ -- Not an algebraic type
+ [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
+ -- violation? Or does it only mean not to apply it again to the same
+ -- subject?
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ elem_tys_either <- mapM vhdl_ty_either real_arg_tys
+ case Either.partitionEithers elem_tys_either of
+ -- No errors in element types
+ ([], elem_tys) -> do
+ let elems = zipWith AST.ElementDec recordlabels elem_tys
+ -- For a single construct datatype, build a record with one field for
+ -- each argument.
+ -- TODO: Add argument type ids to this, to ensure uniqueness
+ -- TODO: Special handling for tuples?
+ let elem_names = concat $ map prettyShow elem_tys
+ let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
+ let ty_def = AST.TDR $ AST.RecordTypeDef elems
+ return $ Right (ty_id, Left ty_def)
+ -- There were errors in element types
+ (errors, _) -> return $ Left $
+ "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+ ++ (concat errors)
+ dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ where
+ -- Create a subst that instantiates all types passed to the tycon
+ -- TODO: I'm not 100% sure that this is the right way to do this. It seems
+ -- to work so far, though..
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+ -- Generate a bunch of labels for fields of a record
+ recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+
+-- | Create a VHDL vector type
+mk_vector_ty ::
+ Type.Type -- ^ The Haskell type of the Vector
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
+
+mk_vector_ty ty = do
+ types_map <- getA vsTypes
+ env <- getA vsHscEnv
+ let (nvec_l, nvec_el) = Type.splitAppTy ty
+ let (nvec, leng) = Type.splitAppTy nvec_l
+ let vec_ty = Type.mkAppTy nvec nvec_el
+ len <- tfp_to_int (tfvec_len_ty ty)
+ let el_ty = tfvec_elem ty
+ el_ty_tm_either <- vhdl_ty_either el_ty
+ case el_ty_tm_either of
+ -- Could create element type
+ Right el_ty_tm -> do
+ let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+ let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
+ case existing_elem_ty of
+ Just t -> do
+ let ty_def = AST.SubtypeIn t (Just range)
+ return (Right (ty_id, Right ty_def))
+ Nothing -> do
+ let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
+ let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
+ modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
+ let ty_def = AST.SubtypeIn vec_id (Just range)
+ return (Right (ty_id, Right ty_def))
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+
+mk_natural_ty ::
+ Int -- ^ The minimum bound (> 0)
+ -> Int -- ^ The maximum bound (> minimum bound)
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
+mk_natural_ty min_bound max_bound = do
+ let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
+ let ty_def = AST.SubtypeIn naturalTM (Just range)
+ return (Right (ty_id, Right ty_def))
+
+mk_unsigned_ty ::
+ Type.Type -- ^ Haskell type of the unsigned integer
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_unsigned_ty ty = do
+ size <- tfp_to_int (sized_word_len_ty ty)
+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn unsignedTM (Just range)
+ return (Right (ty_id, Right ty_def))
+
+mk_signed_ty ::
+ Type.Type -- ^ Haskell type of the signed integer
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_signed_ty ty = do
+ size <- tfp_to_int (sized_int_len_ty ty)
+ let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn signedTM (Just range)
+ return (Right (ty_id, Right ty_def))
+
+-- Finds the field labels for VHDL type generated for the given Core type,
+-- which must result in a record type.
+getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
+getFieldLabels ty = do
+ -- Ensure that the type is generated (but throw away it's VHDLId)
+ let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
+ vhdl_ty error_msg ty
+ -- Get the types map, lookup and unpack the VHDL TypeDef
+ types <- getA vsTypes
+ -- Assume the type for which we want labels is really translatable
+ Right htype <- mkHType ty
+ case Map.lookup htype types of
+ Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
+
+mkHType :: Type.Type -> TypeSession (Either String HType)
+mkHType ty = do
+ -- FIXME: Do we really need to do this here again?
+ let builtin_ty = do -- See if this is a tycon and lookup its name
+ (tycon, args) <- Type.splitTyConApp_maybe ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ Map.lookup name builtin_types
+ case builtin_ty of
+ Just typ ->
+ return $ Right $ BuiltinType $ prettyShow typ
+ Nothing ->
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "TFVec" -> do
+ let el_ty = tfvec_elem ty
+ elem_htype_either <- mkHType el_ty
+ case elem_htype_either of
+ -- Could create element type
+ Right elem_htype -> do
+ len <- tfp_to_int (tfvec_len_ty ty)
+ return $ Right $ VecType len elem_htype
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+ "SizedWord" -> do
+ len <- tfp_to_int (sized_word_len_ty ty)
+ return $ Right $ SizedWType len
+ "SizedInt" -> do
+ len <- tfp_to_int (sized_word_len_ty ty)
+ return $ Right $ SizedIType len
+ "RangedWord" -> do
+ bound <- tfp_to_int (ranged_word_bound_ty ty)
+ return $ Right $ RangedWType bound
+ otherwise -> do
+ mkTyConHType tycon args
+ Nothing -> return $ Right $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =
+ case TyCon.tyConDataCons tycon of
+ -- Not an algebraic type
+ [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ elem_htys_either <- mapM mkHType real_arg_tys
+ case Either.partitionEithers elem_htys_either of
+ -- No errors in element types
+ ([], elem_htys) -> do
+ return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+ -- There were errors in element types
+ (errors, _) -> return $ Left $
+ "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+ ++ (concat errors)
+ dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ where
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+ ty_either <- vhdl_ty_either ty
+ return $ case ty_either of
+ Left _ -> False
+ Right _ -> True
+
+tfp_to_int :: Type.Type -> TypeSession Int
+tfp_to_int ty = do
+ lens <- getA vsTfpInts
+ hscenv <- getA vsHscEnv
+ let norm_ty = normalise_tfp_int hscenv ty
+ let existing_len = Map.lookup (OrdType norm_ty) lens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = eval_tfp_int hscenv ty
+ modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+ return new_len
\ No newline at end of file
--- /dev/null
+--
+-- Some types used by the VHDL module.
+--
+{-# LANGUAGE TemplateHaskell #-}
+module VHDLTypes where
+
+-- Standard imports
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Map as Map
+import Data.Accessor
+import qualified Data.Accessor.Template
+
+-- GHC API imports
+import qualified Type
+import qualified CoreSyn
+import qualified HscTypes
+
+-- ForSyDe imports
+import qualified Language.VHDL.AST as AST
+
+-- Local imports
+
+-- A description of a port of an entity
+type Port = (AST.VHDLId, AST.TypeMark)
+
+-- A description of a VHDL entity. Contains both the entity itself as well as
+-- info on how to map a haskell value (argument / result) on to the entity's
+-- ports.
+data Entity = Entity {
+ ent_id :: AST.VHDLId, -- The id of the entity
+ ent_args :: [Port], -- A mapping of each function argument to port names
+ ent_res :: Port -- A mapping of the function result to port names
+} deriving (Show);
+
+-- A orderable equivalent of CoreSyn's Type for use as a map key
+newtype OrdType = OrdType { getType :: Type.Type }
+instance Eq OrdType where
+ (OrdType a) == (OrdType b) = Type.tcEqType a b
+instance Ord OrdType where
+ compare (OrdType a) (OrdType b) = Type.tcCmpType a b
+
+data HType = StdType OrdType |
+ ADTType String [HType] |
+ VecType Int HType |
+ SizedWType Int |
+ RangedWType Int |
+ SizedIType Int |
+ BuiltinType String
+ deriving (Eq, Ord)
+
+-- A map of a Core type to the corresponding type name
+type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
+
+-- A map of a vector Core element type and function name to the coressponding
+-- VHDLId of the function and the function body.
+type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody)
+
+-- A map of a Haskell function to a hardware signature
+type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
+
+type TfpIntMap = Map.Map OrdType Int
+
+data TypeState = TypeState {
+ -- | A map of Core type -> VHDL Type
+ vsTypes_ :: TypeMap,
+ -- | A list of type declarations
+ vsTypeDecls_ :: [AST.PackageDecItem],
+ -- | A map of vector Core type -> VHDL type function
+ vsTypeFuns_ :: TypeFunMap,
+ vsTfpInts_ :: TfpIntMap,
+ vsHscEnv_ :: HscTypes.HscEnv
+}
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''TypeState )
+-- Define a session
+type TypeSession = State.State TypeState
+
+data VHDLState = VHDLState {
+ -- | A subtype with typing info
+ vsType_ :: TypeState,
+ -- | A map of HsFunction -> hardware signature (entity name, port names,
+ -- etc.)
+ vsSignatures_ :: SignatureMap
+}
+
+-- Derive accessors
+$( Data.Accessor.Template.deriveAccessors ''VHDLState )
+
+-- | The state containing a VHDL Session
+type VHDLSession = State.State VHDLState
+
+-- A function that generates VHDL for a builtin function
+type BuiltinBuilder =
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
+ -> CoreSyn.CoreBndr -- ^ The function called
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
+ -- dictionary arguments).
+ -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements.
+
+-- A map of a builtin function to VHDL function builder
+type NameTable = Map.Map String (Int, BuiltinBuilder )
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ * Neither the name of the copyright holder nor the
+ names of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
--- /dev/null
+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
+
+executable: clash
+main-is: Main.hs
projects / matthijs / master-project / cλash.git / commitdiff