From: Christiaan Baaij Date: Wed, 15 Jul 2009 17:29:53 +0000 (+0200) Subject: Moved clash to it's own library directory, and started on library structure X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=ec4378a8a765c5a064b5cbed347b40c353c778a0;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Moved clash to it's own library directory, and started on library structure --- diff --git a/Constants.hs b/Constants.hs deleted file mode 100644 index e9c4a4a..0000000 --- a/Constants.hs +++ /dev/null @@ -1,298 +0,0 @@ -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" diff --git a/CoreShow.hs b/CoreShow.hs deleted file mode 100644 index 09abed6..0000000 --- a/CoreShow.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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) ++ "__" diff --git a/CoreTools.hs b/CoreTools.hs deleted file mode 100644 index 0c0e1fa..0000000 --- a/CoreTools.hs +++ /dev/null @@ -1,210 +0,0 @@ --- | 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 diff --git a/Generate.hs b/Generate.hs deleted file mode 100644 index 8dc7a0a..0000000 --- a/Generate.hs +++ /dev/null @@ -1,1038 +0,0 @@ -{-# 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 ) ) - ] diff --git a/GhcTools.hs b/GhcTools.hs deleted file mode 100644 index 9c5038c..0000000 --- a/GhcTools.hs +++ /dev/null @@ -1,44 +0,0 @@ -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 diff --git a/HsTools.hs b/HsTools.hs deleted file mode 100644 index 1bad941..0000000 --- a/HsTools.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# 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 "") 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 diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 23ebcfd..0000000 --- a/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -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 diff --git a/Normalize.hs b/Normalize.hs deleted file mode 100644 index 12356e2..0000000 --- a/Normalize.hs +++ /dev/null @@ -1,533 +0,0 @@ -{-# LANGUAGE PackageImports #-} --- --- Functions to bring a Core expression in normal form. This module provides a --- top level function "normalize", and defines the actual transformation passes that --- are performed. --- -module Normalize (normalizeModule) where - --- Standard modules -import Debug.Trace -import qualified Maybe -import qualified "transformers" Control.Monad.Trans as Trans -import qualified Control.Monad as Monad -import qualified Control.Monad.Trans.Writer as Writer -import qualified Data.Map as Map -import qualified Data.Monoid as Monoid -import Data.Accessor - --- GHC API -import CoreSyn -import qualified UniqSupply -import qualified CoreUtils -import qualified Type -import qualified TcType -import qualified Id -import qualified Var -import qualified VarSet -import qualified NameSet -import qualified CoreFVs -import qualified CoreUtils -import qualified MkCore -import qualified HscTypes -import Outputable ( showSDoc, ppr, nest ) - --- Local imports -import NormalizeTypes -import NormalizeTools -import VHDLTypes -import CoreTools -import Pretty - --------------------------------- --- Start of transformations --------------------------------- - --------------------------------- --- η abstraction --------------------------------- -eta, etatop :: Transform -eta expr | is_fun expr && not (is_lam expr) = do - let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr - id <- mkInternalVar "param" arg_ty - change (Lam id (App expr (Var id))) --- Leave all other expressions unchanged -eta e = return e -etatop = notappargs ("eta", eta) - --------------------------------- --- β-reduction --------------------------------- -beta, betatop :: Transform --- Substitute arg for x in expr -beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr --- Propagate the application into the let -beta (App (Let binds expr) arg) = change $ Let binds (App expr arg) --- Propagate the application into each of the alternatives -beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts' - where - alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts - ty' = CoreUtils.applyTypeToArg ty arg --- Leave all other expressions unchanged -beta expr = return expr --- Perform this transform everywhere -betatop = everywhere ("beta", beta) - --------------------------------- --- Cast propagation --------------------------------- --- Try to move casts as much downward as possible. -castprop, castproptop :: Transform -castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty) -castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts') - where - alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts --- Leave all other expressions unchanged -castprop expr = return expr --- Perform this transform everywhere -castproptop = everywhere ("castprop", castprop) - --------------------------------- --- let recursification --------------------------------- -letrec, letrectop :: Transform -letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res --- Leave all other expressions unchanged -letrec expr = return expr --- Perform this transform everywhere -letrectop = everywhere ("letrec", letrec) - --------------------------------- --- let simplification --------------------------------- -letsimpl, letsimpltop :: Transform --- Put the "in ..." value of a let in its own binding, but not when the --- expression is applicable (to prevent loops with inlinefun). -letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do - local_var <- Trans.lift $ is_local_var res - if not local_var - then do - -- If the result is not a local var already (to prevent loops with - -- ourselves), extract it. - id <- mkInternalVar "foo" (CoreUtils.exprType res) - let bind = (id, res) - change $ Let (Rec (bind:binds)) (Var id) - else - -- If the result is already a local var, don't extract it. - return expr - --- Leave all other expressions unchanged -letsimpl expr = return expr --- Perform this transform everywhere -letsimpltop = everywhere ("letsimpl", letsimpl) - --------------------------------- --- let flattening --------------------------------- -letflat, letflattop :: Transform -letflat (Let (Rec binds) expr) = do - -- Turn each binding into a list of bindings (possibly containing just one - -- element, of course) - bindss <- Monad.mapM flatbind binds - -- Concat all the bindings - let binds' = concat bindss - -- Return the new let. We don't use change here, since possibly nothing has - -- changed. If anything has changed, flatbind has already flagged that - -- change. - return $ Let (Rec binds') expr - where - -- Turns a binding of a let into a multiple bindings, or any other binding - -- into a list with just that binding - flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)] - flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds) - flatbind (b, expr) = return [(b, expr)] --- Leave all other expressions unchanged -letflat expr = return expr --- Perform this transform everywhere -letflattop = everywhere ("letflat", letflat) - --------------------------------- --- Simple let binding removal --------------------------------- --- Remove a = b bindings from let expressions everywhere -letremovetop :: Transform -letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e)) - --------------------------------- --- Function inlining --------------------------------- --- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let --- expressions everywhere. This means that any value that still needs to be --- applied to something else (polymorphic values need to be applied to a --- Type) will be inlined, and will eventually be applied to all their --- arguments. --- --- This is a tricky function, which is prone to create loops in the --- transformations. To fix this, we make sure that no transformation will --- create a new let binding with a function type. These other transformations --- will just not work on those function-typed values at first, but the other --- transformations (in particular β-reduction) should make sure that the type --- of those values eventually becomes primitive. -inlinenonreptop :: Transform -inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd)) - --------------------------------- --- Scrutinee simplification --------------------------------- -scrutsimpl,scrutsimpltop :: Transform --- Don't touch scrutinees that are already simple -scrutsimpl expr@(Case (Var _) _ _ _) = return expr --- Replace all other cases with a let that binds the scrutinee and a new --- simple scrutinee, but not when the scrutinee is applicable (to prevent --- loops with inlinefun, though I don't think a scrutinee can be --- applicable...) -scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do - id <- mkInternalVar "scrut" (CoreUtils.exprType scrut) - change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts) --- Leave all other expressions unchanged -scrutsimpl expr = return expr --- Perform this transform everywhere -scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl) - --------------------------------- --- Case binder wildening --------------------------------- -casewild, casewildtop :: Transform -casewild expr@(Case scrut b ty alts) = do - (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts - let bindings = concat bindingss - -- Replace the case with a let with bindings and a case - let newlet = (Let (Rec bindings) (Case scrut b ty alts')) - -- If there are no non-wild binders, or this case is already a simple - -- selector (i.e., a single alt with exactly one binding), already a simple - -- selector altan no bindings (i.e., no wild binders in the original case), - -- don't change anything, otherwise, replace the case. - if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet - where - -- Generate a single wild binder, since they are all the same - wild = MkCore.mkWildBinder - -- Wilden the binders of one alt, producing a list of bindings as a - -- sideeffect. - doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt) - doalt (con, bndrs, expr) = do - bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..] - let bindings = Maybe.catMaybes bindings_maybe - -- We replace the binders with wild binders only. We can leave expr - -- unchanged, since the new bindings bind the same vars as the original - -- did. - let newalt = (con, wildbndrs, expr) - return (bindings, newalt) - where - -- Make all binders wild - wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs - -- A set of all the binders that are used by the expression - free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr - -- Creates a case statement to retrieve the ith element from the scrutinee - -- and binds that to b. - mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr)) - mkextracts b i = - if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b) - -- Don't create extra bindings for binders that are already wild - -- (e.g. not in the free variables of expr, so unused), or for - -- binders that bind function types (to prevent loops with - -- inlinefun). - then return Nothing - else do - -- Create on new binder that will actually capture a value in this - -- case statement, and return it - let bty = (Id.idType b) - id <- mkInternalVar "sel" bty - let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs - return $ Just (b, Case scrut b bty [(con, binders, Var id)]) --- Leave all other expressions unchanged -casewild expr = return expr --- Perform this transform everywhere -casewildtop = everywhere ("casewild", casewild) - --------------------------------- --- Case value simplification --------------------------------- -casevalsimpl, casevalsimpltop :: Transform -casevalsimpl expr@(Case scrut b ty alts) = do - -- Try to simplify each alternative, resulting in an optional binding and a - -- new alternative. - (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts - let bindings = Maybe.catMaybes bindings_maybe - -- Create a new let around the case, that binds of the cases values. - let newlet = Let (Rec bindings) (Case scrut b ty alts') - -- If there were no values that needed and allowed simplification, don't - -- change the case. - if null bindings then return expr else change newlet - where - doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt) - -- Don't simplify values that are already simple - doalt alt@(con, bndrs, Var _) = return (Nothing, alt) - -- Simplify each alt by creating a new id, binding the case value to it and - -- replacing the case value with that id. Only do this when the case value - -- does not use any of the binders bound by this alternative, for that would - -- cause those binders to become unbound when moving the value outside of - -- the case statement. Also, don't create a binding for applicable - -- expressions, to prevent loops with inlinefun. - doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do - id <- mkInternalVar "caseval" (CoreUtils.exprType expr) - -- We don't flag a change here, since casevalsimpl will do that above - -- based on Just we return here. - return $ (Just (id, expr), (con, bndrs, Var id)) - -- Find if any of the binders are used by expr - where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr - -- Don't simplify anything else - doalt alt = return (Nothing, alt) --- Leave all other expressions unchanged -casevalsimpl expr = return expr --- Perform this transform everywhere -casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl) - --------------------------------- --- Case removal --------------------------------- --- Remove case statements that have only a single alternative and only wild --- binders. -caseremove, caseremovetop :: Transform --- Replace a useless case by the value of its single alternative -caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr - -- Find if any of the binders are used by expr - where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr --- Leave all other expressions unchanged -caseremove expr = return expr --- Perform this transform everywhere -caseremovetop = everywhere ("caseremove", caseremove) - --------------------------------- --- Argument extraction --------------------------------- --- Make sure that all arguments of a representable type are simple variables. -appsimpl, appsimpltop :: Transform --- Simplify all representable arguments. Do this by introducing a new Let --- that binds the argument and passing the new binder in the application. -appsimpl expr@(App f arg) = do - -- Check runtime representability - repr <- isRepr arg - local_var <- Trans.lift $ is_local_var arg - if repr && not local_var - then do -- Extract representable arguments - id <- mkInternalVar "arg" (CoreUtils.exprType arg) - change $ Let (Rec [(id, arg)]) (App f (Var id)) - else -- Leave non-representable arguments unchanged - return expr --- Leave all other expressions unchanged -appsimpl expr = return expr --- Perform this transform everywhere -appsimpltop = everywhere ("appsimpl", appsimpl) - --------------------------------- --- Function-typed argument propagation --------------------------------- --- Remove all applications to function-typed arguments, by duplication the --- function called with the function-typed parameter replaced by the free --- variables of the argument passed in. -argprop, argproptop :: Transform --- Transform any application of a named function (i.e., skip applications of --- lambda's). Also skip applications that have arguments with free type --- variables, since we can't inline those. -argprop expr@(App _ _) | is_var fexpr = do - -- Find the body of the function called - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - Just body -> do - -- Process each of the arguments in turn - (args', changed) <- Writer.listen $ mapM doarg args - -- See if any of the arguments changed - case Monoid.getAny changed of - True -> do - let (newargs', newparams', oldargs) = unzip3 args' - let newargs = concat newargs' - let newparams = concat newparams' - -- Create a new body that consists of a lambda for all new arguments and - -- the old body applied to some arguments. - let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) - -- Create a new function with the same name but a new body - newf <- mkFunction f newbody - -- Replace the original application with one of the new function to the - -- new arguments. - change $ MkCore.mkCoreApps (Var newf) newargs - False -> - -- Don't change the expression if none of the arguments changed - return expr - - -- If we don't have a body for the function called, leave it unchanged (it - -- should be a primitive function then). - Nothing -> return expr - where - -- Find the function called and the arguments - (fexpr, args) = collectArgs expr - Var f = fexpr - - -- Process a single argument and return (args, bndrs, arg), where args are - -- the arguments to replace the given argument in the original - -- application, bndrs are the binders to include in the top-level lambda - -- in the new function body, and arg is the argument to apply to the old - -- function body. - doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr) - doarg arg = do - repr <- isRepr arg - bndrs <- Trans.lift getGlobalBinders - let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs) - if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) - then do - -- Propagate all complex arguments that are not representable, but not - -- arguments with free type variables (since those would require types - -- not known yet, which will always be known eventually). - -- Find interesting free variables, each of which should be passed to - -- the new function instead of the original function argument. - -- - -- Interesting vars are those that are local, but not available from the - -- top level scope (functions from this module are defined as local, but - -- they're not local to this function, so we can freely move references - -- to them into another function). - let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg - -- Mark the current expression as changed - setChanged - return (map Var free_vars, free_vars, arg) - else do - -- Representable types will not be propagated, and arguments with free - -- type variables will be propagated later. - -- TODO: preserve original naming? - id <- mkBinderFor arg "param" - -- Just pass the original argument to the new function, which binds it - -- to a new id and just pass that new id to the old function body. - return ([arg], [id], mkReferenceTo id) --- Leave all other expressions unchanged -argprop expr = return expr --- Perform this transform everywhere -argproptop = everywhere ("argprop", argprop) - --------------------------------- --- Function-typed argument extraction --------------------------------- --- This transform takes any function-typed argument that cannot be propagated --- (because the function that is applied to it is a builtin function), and --- puts it in a brand new top level binder. This allows us to for example --- apply map to a lambda expression This will not conflict with inlinefun, --- since that only inlines local let bindings, not top level bindings. -funextract, funextracttop :: Transform -funextract expr@(App _ _) | is_var fexpr = do - body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - -- We don't have a function body for f, so we can perform this transform. - Nothing -> do - -- Find the new arguments - args' <- mapM doarg args - -- And update the arguments. We use return instead of changed, so the - -- changed flag doesn't get set if none of the args got changed. - return $ MkCore.mkCoreApps fexpr args' - -- We have a function body for f, leave this application to funprop - Just _ -> return expr - where - -- Find the function called and the arguments - (fexpr, args) = collectArgs expr - Var f = fexpr - -- Change any arguments that have a function type, but are not simple yet - -- (ie, a variable or application). This means to create a new function - -- for map (\f -> ...) b, but not for map (foo a) b. - -- - -- We could use is_applicable here instead of is_fun, but I think - -- arguments to functions could only have forall typing when existential - -- typing is enabled. Not sure, though. - doarg arg | not (is_simple arg) && is_fun arg = do - -- Create a new top level binding that binds the argument. Its body will - -- be extended with lambda expressions, to take any free variables used - -- by the argument expression. - let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg - let body = MkCore.mkCoreLams free_vars arg - id <- mkBinderFor body "fun" - Trans.lift $ addGlobalBind id body - -- Replace the argument with a reference to the new function, applied to - -- all vars it uses. - change $ MkCore.mkCoreApps (Var id) (map Var free_vars) - -- Leave all other arguments untouched - doarg arg = return arg - --- Leave all other expressions unchanged -funextract expr = return expr --- Perform this transform everywhere -funextracttop = everywhere ("funextract", funextract) - --------------------------------- --- End of transformations --------------------------------- - - - - --- What transforms to run? -transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop] - --- Turns the given bind into VHDL -normalizeModule :: - HscTypes.HscEnv - -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use - -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module) - -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings) - -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful - -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL - -normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do - -- Put all the bindings in this module in the tsBindings map - putA tsBindings (Map.fromList bindings) - -- (Recursively) normalize each of the requested bindings - mapM normalizeBind generate_for - -- Get all initial bindings and the ones we produced - bindings_map <- getA tsBindings - let bindings = Map.assocs bindings_map - normalized_bindings <- getA tsNormalized - typestate <- getA tsType - -- But return only the normalized bindings - return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate) - -normalizeBind :: CoreBndr -> TransformSession () -normalizeBind bndr = - -- Don't normalize global variables, these should be either builtin - -- functions or data constructors. - Monad.when (Var.isLocalId bndr) $ do - -- Skip binders that have a polymorphic type, since it's impossible to - -- create polymorphic hardware. - if is_poly (Var bndr) - then - -- This should really only happen at the top level... TODO: Give - -- a different error if this happens down in the recursion. - error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" - else do - normalized_funcs <- getA tsNormalized - -- See if this function was normalized already - if VarSet.elemVarSet bndr normalized_funcs - then - -- Yup, don't do it again - return () - else do - -- Nope, note that it has been and do it. - modA tsNormalized (flip VarSet.extendVarSet bndr) - expr_maybe <- getGlobalBind bndr - case expr_maybe of - Just expr -> do - -- Introduce an empty Let at the top level, so there will always be - -- a let in the expression (none of the transformations will remove - -- the last let). - let expr' = Let (Rec []) expr - -- Normalize this expression - trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return () - expr' <- dotransforms transforms expr' - trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return () - -- And store the normalized version in the session - modA tsBindings (Map.insert bndr expr') - -- Find all vars used with a function type. All of these should be global - -- binders (i.e., functions used), since any local binders with a function - -- type should have been inlined already. - bndrs <- getGlobalBinders - let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr' - let used_funcs = VarSet.varSetElems used_funcs_set - -- Process each of the used functions recursively - mapM normalizeBind used_funcs - return () - -- We don't have a value for this binder. This really shouldn't - -- happen for local id's... - Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!" diff --git a/NormalizeTools.hs b/NormalizeTools.hs deleted file mode 100644 index 920d28b..0000000 --- a/NormalizeTools.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# 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 diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs deleted file mode 100644 index 56cba91..0000000 --- a/NormalizeTypes.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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 diff --git a/Pretty.hs b/Pretty.hs deleted file mode 100644 index d88846a..0000000 --- a/Pretty.hs +++ /dev/null @@ -1,163 +0,0 @@ -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 diff --git a/Translator.hs b/Translator.hs deleted file mode 100644 index 260b1cd..0000000 --- a/Translator.hs +++ /dev/null @@ -1,372 +0,0 @@ -module Translator where -import qualified Directory -import qualified System.FilePath as FilePath -import qualified List -import Debug.Trace -import qualified Control.Arrow as Arrow -import GHC hiding (loadModule, sigName) -import CoreSyn -import qualified CoreUtils -import qualified Var -import qualified Type -import qualified TyCon -import qualified DataCon -import qualified HscMain -import qualified SrcLoc -import qualified FastString -import qualified Maybe -import qualified Module -import qualified Data.Foldable as Foldable -import qualified Control.Monad.Trans.State as State -import Name -import qualified Data.Map as Map -import Data.Accessor -import Data.Generics -import NameEnv ( lookupNameEnv ) -import qualified HscTypes -import HscTypes ( cm_binds, cm_types ) -import MonadUtils ( liftIO ) -import Outputable ( showSDoc, ppr, showSDocDebug ) -import GHC.Paths ( libdir ) -import DynFlags ( defaultDynFlags ) -import qualified UniqSupply -import List ( find ) -import qualified List -import qualified Monad - --- The following modules come from the ForSyDe project. They are really --- internal modules, so ForSyDe.cabal has to be modified prior to installing --- ForSyDe to get access to these modules. -import qualified Language.VHDL.AST as AST -import qualified Language.VHDL.FileIO -import qualified Language.VHDL.Ppr as Ppr --- This is needed for rendering the pretty printed VHDL -import Text.PrettyPrint.HughesPJ (render) - -import TranslatorTypes -import HsValueMap -import Pretty -import Normalize --- import Flatten --- import FlattenTypes -import VHDLTypes -import qualified VHDL - -makeVHDL :: String -> String -> Bool -> IO () -makeVHDL filename name stateful = do - -- Load the module - (core, env) <- loadModule filename - -- Translate to VHDL - vhdl <- moduleToVHDL env core [(name, stateful)] - -- Write VHDL to file - let dir = "./vhdl/" ++ name ++ "/" - prepareDir dir - mapM (writeVHDL dir) vhdl - return () - -listBindings :: String -> IO [()] -listBindings filename = do - (core, env) <- loadModule filename - let binds = CoreSyn.flattenBinds $ cm_binds core - mapM (listBinding) binds - -listBinding :: (CoreBndr, CoreExpr) -> IO () -listBinding (b, e) = do - putStr "\nBinder: " - putStr $ show b - putStr "\nExpression: \n" - putStr $ prettyShow e - putStr "\n\n" - putStr $ showSDoc $ ppr e - putStr "\n\n" - putStr $ showSDoc $ ppr $ CoreUtils.exprType e - putStr "\n\n" - --- | Show the core structure of the given binds in the given file. -listBind :: String -> String -> IO () -listBind filename name = do - (core, env) <- loadModule filename - let [(b, expr)] = findBinds core [name] - putStr "\n" - putStr $ prettyShow expr - putStr "\n\n" - putStr $ showSDoc $ ppr expr - putStr "\n\n" - putStr $ showSDoc $ ppr $ CoreUtils.exprType expr - putStr "\n\n" - --- | Translate the binds with the given names from the given core module to --- VHDL. The Bool in the tuple makes the function stateful (True) or --- stateless (False). -moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDL env core list = do - let (names, statefuls) = unzip list - let binds = map fst $ findBinds core names - -- Generate a UniqSupply - -- Running - -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . - -- on the compiler dir of ghc suggests that 'z' is not used to generate a - -- unique supply anywhere. - uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' - -- Turn bind into VHDL - let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) - let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls - let vhdl = VHDL.createDesignFiles typestate normalized_bindings - mapM (putStr . render . Ppr.ppr . snd) vhdl - --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" - return vhdl - where - --- | Prepares the directory for writing VHDL files. This means creating the --- dir if it does not exist and removing all existing .vhdl files from it. -prepareDir :: String -> IO() -prepareDir dir = do - -- Create the dir if needed - exists <- Directory.doesDirectoryExist dir - Monad.unless exists $ Directory.createDirectory dir - -- Find all .vhdl files in the directory - files <- Directory.getDirectoryContents dir - let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files - -- Prepend the dirname to the filenames - let abs_to_remove = map (FilePath.combine dir) to_remove - -- Remove the files - mapM_ Directory.removeFile abs_to_remove - --- | Write the given design file to a file with the given name inside the --- given dir -writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO () -writeVHDL dir (name, vhdl) = do - -- Find the filename - let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl" - -- Write the file - Language.VHDL.FileIO.writeDesignFile vhdl fname - --- | Loads the given file and turns it into a core module. -loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv) -loadModule filename = - defaultErrorHandler defaultDynFlags $ do - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - --target <- guessTarget "adder.hs" Nothing - --liftIO (print (showSDoc (ppr (target)))) - --liftIO $ printTarget target - --setTargets [target] - --load LoadAllTargets - --core <- GHC.compileToCoreSimplified "Adders.hs" - core <- GHC.compileToCoreModule filename - env <- GHC.getSession - return (core, env) - --- | Extracts the named binds from the given module. -findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)] -findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names - --- | Extract a named bind from the given list of binds -findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr) -findBind binds lookfor = - -- This ignores Recs and compares the name of the bind with lookfor, - -- disregarding any namespaces in OccName and extra attributes in Name and - -- Var. - find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds - --- | Flattens the given bind into the given signature and adds it to the --- session. Then (recursively) finds any functions it uses and does the same --- with them. --- flattenBind :: --- HsFunction -- The signature to flatten into --- -> (CoreBndr, CoreExpr) -- The bind to flatten --- -> TranslatorState () --- --- flattenBind hsfunc bind@(var, expr) = do --- -- Flatten the function --- let flatfunc = flattenFunction hsfunc bind --- -- Propagate state variables --- let flatfunc' = propagateState hsfunc flatfunc --- -- Store the flat function in the session --- modA tsFlatFuncs (Map.insert hsfunc flatfunc') --- -- Flatten any functions used --- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc') --- mapM_ resolvFunc used_hsfuncs - --- | Decide which incoming state variables will become state in the --- given function, and which will be propagate to other applied --- functions. --- propagateState :: --- HsFunction --- -> FlatFunction --- -> FlatFunction --- --- propagateState hsfunc flatfunc = --- flatfunc {flat_defs = apps', flat_sigs = sigs'} --- where --- (olds, news) = unzip $ getStateSignals hsfunc flatfunc --- states' = zip olds news --- -- Find all signals used by all sigdefs --- uses = concatMap sigDefUses (flat_defs flatfunc) --- -- Find all signals that are used more than once (is there a --- -- prettier way to do this?) --- multiple_uses = uses List.\\ (List.nub uses) --- -- Find the states whose "old state" signal is used only once --- single_use_states = filter ((`notElem` multiple_uses) . fst) states' --- -- See if these single use states can be propagated --- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc) --- substate_sigs = concat substate_sigss --- -- Mark any propagated state signals as SigSubState --- sigs' = map --- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info)) --- (flat_sigs flatfunc) - --- | Propagate the state into a single function application. --- propagateState' :: --- [(SignalId, SignalId)] --- -- ^ TODO --- -> SigDef -- ^ The SigDef to process. --- -> ([SignalId], SigDef) --- -- ^ Any signal ids that should become substates, --- -- and the resulting application. --- --- propagateState' states def = --- if (is_FApp def) then --- (our_old ++ our_new, def {appFunc = hsfunc'}) --- else --- ([], def) --- where --- hsfunc = appFunc def --- args = appArgs def --- res = appRes def --- our_states = filter our_state states --- -- A state signal belongs in this function if the old state is --- -- passed in, and the new state returned --- our_state (old, new) = --- any (old `Foldable.elem`) args --- && new `Foldable.elem` res --- (our_old, our_new) = unzip our_states --- -- Mark the result --- zipped_res = zipValueMaps res (hsFuncRes hsfunc) --- res' = fmap (mark_state (zip our_new [0..])) zipped_res --- -- Mark the args --- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc) --- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args --- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'} --- --- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse --- mark_state states (id, use) = --- case lookup id states of --- Nothing -> use --- Just state_id -> State state_id - --- | Returns pairs of signals that should be mapped to state in this function. --- getStateSignals :: --- HsFunction -- | The function to look at --- -> FlatFunction -- | The function to look at --- -> [(SignalId, SignalId)] --- -- | TODO The state signals. The first is the state number, the second the --- -- signal to assign the current state to, the last is the signal --- -- that holds the new state. --- --- getStateSignals hsfunc flatfunc = --- [(old_id, new_id) --- | (old_num, old_id) <- args --- , (new_num, new_id) <- res --- , old_num == new_num] --- where --- sigs = flat_sigs flatfunc --- -- Translate args and res to lists of (statenum, sigid) --- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc) --- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc) - --- | Find the given function, flatten it and add it to the session. Then --- (recursively) do the same for any functions used. --- resolvFunc :: --- HsFunction -- | The function to look for --- -> TranslatorState () --- --- resolvFunc hsfunc = do --- flatfuncmap <- getA tsFlatFuncs --- -- Don't do anything if there is already a flat function for this hsfunc or --- -- when it is a builtin function. --- Monad.unless (Map.member hsfunc flatfuncmap) $ do --- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do --- -- New function, resolve it --- core <- getA tsCoreModule --- -- Find the named function --- let name = (hsFuncName hsfunc) --- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name --- case bind of --- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module." --- Just b -> flattenBind hsfunc b - --- | Translate a top level function declaration to a HsFunction. i.e., which --- interface will be provided by this function. This function essentially --- defines the "calling convention" for hardware models. --- mkHsFunction :: --- Var.Var -- ^ The function defined --- -> Type -- ^ The function type (including arguments!) --- -> Bool -- ^ Is this a stateful function? --- -> HsFunction -- ^ The resulting HsFunction --- --- mkHsFunction f ty stateful= --- HsFunction hsname hsargs hsres --- where --- hsname = getOccString f --- (arg_tys, res_ty) = Type.splitFunTys ty --- (hsargs, hsres) = --- if stateful --- then --- let --- -- The last argument must be state --- state_ty = last arg_tys --- state = useAsState (mkHsValueMap state_ty) --- -- All but the last argument are inports --- inports = map (useAsPort . mkHsValueMap)(init arg_tys) --- hsargs = inports ++ [state] --- hsres = case splitTupleType res_ty of --- -- Result type must be a two tuple (state, ports) --- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty --- then --- Tuple [state, useAsPort (mkHsValueMap outport_ty)] --- else --- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty) --- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports." --- in --- (hsargs, hsres) --- else --- -- Just use everything as a port --- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty) - --- | Adds signal names to the given FlatFunction --- nameFlatFunction :: --- FlatFunction --- -> FlatFunction --- --- nameFlatFunction flatfunc = --- -- Name the signals --- let --- s = flat_sigs flatfunc --- s' = map nameSignal s in --- flatfunc { flat_sigs = s' } --- where --- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo) --- nameSignal (id, info) = --- let hints = nameHints info in --- let parts = ("sig" : hints) ++ [show id] in --- let name = concat $ List.intersperse "_" parts in --- (id, info {sigName = Just name}) --- --- -- | Splits a tuple type into a list of element types, or Nothing if the type --- -- is not a tuple type. --- splitTupleType :: --- Type -- ^ The type to split --- -> Maybe [Type] -- ^ The tuples element types --- --- splitTupleType ty = --- case Type.splitTyConApp_maybe ty of --- Just (tycon, args) -> if TyCon.isTupleTyCon tycon --- then --- Just args --- else --- Nothing --- Nothing -> Nothing - --- vim: set ts=8 sw=2 sts=2 expandtab: diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs deleted file mode 100644 index 1286a41..0000000 --- a/TranslatorTypes.hs +++ /dev/null @@ -1,37 +0,0 @@ --- --- 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: diff --git a/VHDL.hs b/VHDL.hs deleted file mode 100644 index 1a8f394..0000000 --- a/VHDL.hs +++ /dev/null @@ -1,298 +0,0 @@ --- --- Functions to generate VHDL from FlatFunctions --- -module VHDL where - --- Standard modules -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Maybe -import qualified Control.Monad as Monad -import qualified Control.Arrow as Arrow -import qualified Control.Monad.Trans.State as State -import qualified Data.Monoid as Monoid -import Data.Accessor -import Data.Accessor.MonadState as MonadState -import Debug.Trace - --- ForSyDe -import qualified Language.VHDL.AST as AST - --- GHC API -import CoreSyn ---import qualified Type -import qualified Name -import qualified Var -import qualified Id -import qualified IdInfo -import qualified TyCon -import qualified DataCon ---import qualified CoreSubst -import qualified CoreUtils -import Outputable ( showSDoc, ppr ) - --- Local imports -import VHDLTypes -import VHDLTools -import Pretty -import CoreTools -import Constants -import Generate - -createDesignFiles :: - TypeState - -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] - -> [(AST.VHDLId, AST.DesignFile)] - -createDesignFiles init_typestate binds = - (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) : - map (Arrow.second $ AST.DesignFile full_context) units - - where - init_session = VHDLState init_typestate Map.empty - (units, final_session) = - State.runState (createLibraryUnits binds) init_session - tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) - ty_decls = final_session ^. vsType ^. vsTypeDecls - tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def - tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing) - tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) - ieee_context = [ - AST.Library $ mkVHDLBasicId "IEEE", - mkUseAll ["IEEE", "std_logic_1164"], - mkUseAll ["IEEE", "numeric_std"] - ] - full_context = - mkUseAll ["work", "types"] - : (mkUseAll ["work"] - : ieee_context) - type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) - type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls - subProgSpecs = map subProgSpec tyfun_decls - subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec - --- Create a use foo.bar.all statement. Takes a list of components in the used --- name. Must contain at least two components -mkUseAll :: [String] -> AST.ContextItem -mkUseAll ss = - AST.Use $ from AST.:.: AST.All - where - base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss) - from = foldl select base_prefix (tail ss) - select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s) - -createLibraryUnits :: - [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] - -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])] - -createLibraryUnits binds = do - entities <- Monad.mapM createEntity binds - archs <- Monad.mapM createArchitecture binds - return $ zipWith - (\ent arch -> - let AST.EntityDec id _ = ent in - (id, [AST.LUEntity ent, AST.LUArch arch]) - ) - entities archs - --- | Create an entity for a given function -createEntity :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function - -> VHDLSession AST.EntityDec -- | The resulting entity - -createEntity (fname, expr) = do - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr - args' <- Monad.mapM mkMap args - -- There must be a let at top level - let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr - res' <- mkMap res - let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname - let ent_decl' = createEntityAST vhdl_id args' res' - let AST.EntityDec entity_id _ = ent_decl' - let signature = Entity entity_id args' res' - modA vsSignatures (Map.insert fname signature) - return ent_decl' - where - mkMap :: - --[(SignalId, SignalInfo)] - CoreSyn.CoreBndr - -> VHDLSession Port - -- We only need the vsTypes element from the state - mkMap = (\bndr -> - let - --info = Maybe.fromMaybe - -- (error $ "Signal not found in the name map? This should not happen!") - -- (lookup id sigmap) - -- Assume the bndr has a valid VHDL id already - id = varToVHDLId bndr - ty = Var.varType bndr - error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr - in do - type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty - return (id, type_mark) - ) - - -- | Create the VHDL AST for an entity -createEntityAST :: - AST.VHDLId -- | The name of the function - -> [Port] -- | The entity's arguments - -> Port -- | The entity's result - -> AST.EntityDec -- | The entity with the ent_decl filled in as well - -createEntityAST vhdl_id args res = - AST.EntityDec vhdl_id ports - where - -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. - ports = map (mkIfaceSigDec AST.In) args - ++ [mkIfaceSigDec AST.Out res] - ++ [clk_port] - -- Add a clk port if we have state - clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM - --- | Create a port declaration -mkIfaceSigDec :: - AST.Mode -- | The mode for the port (In / Out) - -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port - -> AST.IfaceSigDec -- | The resulting port declaration - -mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty - -{- --- | Generate a VHDL entity name for the given hsfunc -mkEntityId hsfunc = - -- TODO: This doesn't work for functions with multiple signatures! - -- Use a Basic Id, since using extended id's for entities throws off - -- precision and causes problems when generating filenames. - mkVHDLBasicId $ hsFuncName hsfunc --} - --- | Create an architecture for a given function -createArchitecture :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function - -> VHDLSession AST.ArchBody -- ^ The architecture for this function - -createArchitecture (fname, expr) = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!") - (Map.lookup fname signaturemap) - let entity_id = ent_id signature - -- Strip off lambda's, these will be arguments - let (args, letexpr) = CoreSyn.collectBinders expr - -- There must be a let at top level - let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr - - -- Create signal declarations for all binders in the let expression, except - -- for the output port (that will already have an output port declared in - -- the entity). - sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) - let sig_decs = Maybe.catMaybes $ sig_dec_maybes - - statementss <- Monad.mapM mkConcSm binds - let statements = concat statementss - return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') - where - procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc) - procs' = map AST.CSPSm procs - -- mkSigDec only uses vsTypes from the state - mkSigDec' = mkSigDec - -{- --- | Looks up all pairs of old state, new state signals, together with --- the state id they represent. -makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)] -makeStatePairs flatfunc = - [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) - | old_info <- map snd (flat_sigs flatfunc) - , new_info <- map snd (flat_sigs flatfunc) - -- old_info must be an old state (and, because of the next equality, - -- new_info must be a new state). - , Maybe.isJust $ oldStateId $ sigUse old_info - -- And the state numbers must match - , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)] - - -- Replace the second tuple element with the corresponding SignalInfo - --args_states = map (Arrow.second $ signalInfo sigs) args -mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm -mkStateProcSm (num, old, new) = - AST.ProcSm label [clk] [statement] - where - label = mkVHDLExtId $ "state_" ++ (show num) - clk = mkVHDLExtId "clk" - rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge" - wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing] - assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform - rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] - statement = AST.IfSm rising_edge_clk [assign] [] Nothing - --- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo --- is not named. -getSignalId :: SignalInfo -> AST.VHDLId -getSignalId info = - mkVHDLExtId $ Maybe.fromMaybe - (error $ "Unnamed signal? This should not happen!") - (sigName info) --} - -mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) -mkSigDec bndr = - if True then do --isInternalSigUse use || isStateSigUse use then do - let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) - return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) - else - return Nothing - --- | Transforms a core binding into a VHDL concurrent statement -mkConcSm :: - (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process - -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. - - --- Ignore Cast expressions, they should not longer have any meaning as long as --- the type works out. -mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) - --- Simple a = b assignments are just like applications, but without arguments. --- We can't just generate an unconditional assignment here, since b might be a --- top level binding (e.g., a function with no arguments). -mkConcSm (bndr, Var v) = do - genApplication (Left bndr) v [] - -mkConcSm (bndr, app@(CoreSyn.App _ _))= do - let (CoreSyn.Var f, args) = CoreSyn.collectArgs app - let valargs = get_val_args (Var.varType f) args - genApplication (Left bndr) f (map Left valargs) - --- A single alt case must be a selector. This means thee scrutinee is a simple --- variable, the alternative is a dataalt with a single non-wild binder that --- is also returned. -mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = - case alt of - (DataAlt dc, bndrs, (Var sel_bndr)) -> do - case List.elemIndex sel_bndr bndrs of - Just i -> do - labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut) - let label = labels!!i - let sel_name = mkSelectedName (varToVHDLName scrut) label - let sel_expr = AST.PrimName sel_name - return [mkUncondAssign (Left bndr) sel_expr] - Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) - - _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) - --- Multiple case alt are be conditional assignments and have only wild --- binders in the alts and only variables in the case values and a variable --- for a scrutinee. We check the constructor of the second alt, since the --- first is the default case, if there is any. -mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do - scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut - let cond_expr = scrut' AST.:=: (altconToVHDLExpr con) - true_expr <- MonadState.lift vsType $ varToVHDLExpr true - false_expr <- MonadState.lift vsType $ varToVHDLExpr false - return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] - -mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives" -mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee" -mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr diff --git a/VHDLTools.hs b/VHDLTools.hs deleted file mode 100644 index 6e6a0c4..0000000 --- a/VHDLTools.hs +++ /dev/null @@ -1,534 +0,0 @@ -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 diff --git a/VHDLTypes.hs b/VHDLTypes.hs deleted file mode 100644 index 8712043..0000000 --- a/VHDLTypes.hs +++ /dev/null @@ -1,103 +0,0 @@ --- --- 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: diff --git "a/c\316\273ash.cabal" "b/c\316\273ash.cabal" deleted file mode 100644 index 3eb5dca..0000000 --- "a/c\316\273ash.cabal" +++ /dev/null @@ -1,24 +0,0 @@ -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 diff --git "a/c\316\273ash/CLasH/Normalize/Normalize.hs" "b/c\316\273ash/CLasH/Normalize/Normalize.hs" new file mode 100644 index 0000000..12356e2 --- /dev/null +++ "b/c\316\273ash/CLasH/Normalize/Normalize.hs" @@ -0,0 +1,533 @@ +{-# LANGUAGE PackageImports #-} +-- +-- Functions to bring a Core expression in normal form. This module provides a +-- top level function "normalize", and defines the actual transformation passes that +-- are performed. +-- +module Normalize (normalizeModule) where + +-- Standard modules +import Debug.Trace +import qualified Maybe +import qualified "transformers" Control.Monad.Trans as Trans +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Writer as Writer +import qualified Data.Map as Map +import qualified Data.Monoid as Monoid +import Data.Accessor + +-- GHC API +import CoreSyn +import qualified UniqSupply +import qualified CoreUtils +import qualified Type +import qualified TcType +import qualified Id +import qualified Var +import qualified VarSet +import qualified NameSet +import qualified CoreFVs +import qualified CoreUtils +import qualified MkCore +import qualified HscTypes +import Outputable ( showSDoc, ppr, nest ) + +-- Local imports +import NormalizeTypes +import NormalizeTools +import VHDLTypes +import CoreTools +import Pretty + +-------------------------------- +-- Start of transformations +-------------------------------- + +-------------------------------- +-- η abstraction +-------------------------------- +eta, etatop :: Transform +eta expr | is_fun expr && not (is_lam expr) = do + let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr + id <- mkInternalVar "param" arg_ty + change (Lam id (App expr (Var id))) +-- Leave all other expressions unchanged +eta e = return e +etatop = notappargs ("eta", eta) + +-------------------------------- +-- β-reduction +-------------------------------- +beta, betatop :: Transform +-- Substitute arg for x in expr +beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr +-- Propagate the application into the let +beta (App (Let binds expr) arg) = change $ Let binds (App expr arg) +-- Propagate the application into each of the alternatives +beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts' + where + alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts + ty' = CoreUtils.applyTypeToArg ty arg +-- Leave all other expressions unchanged +beta expr = return expr +-- Perform this transform everywhere +betatop = everywhere ("beta", beta) + +-------------------------------- +-- Cast propagation +-------------------------------- +-- Try to move casts as much downward as possible. +castprop, castproptop :: Transform +castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty) +castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts') + where + alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts +-- Leave all other expressions unchanged +castprop expr = return expr +-- Perform this transform everywhere +castproptop = everywhere ("castprop", castprop) + +-------------------------------- +-- let recursification +-------------------------------- +letrec, letrectop :: Transform +letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res +-- Leave all other expressions unchanged +letrec expr = return expr +-- Perform this transform everywhere +letrectop = everywhere ("letrec", letrec) + +-------------------------------- +-- let simplification +-------------------------------- +letsimpl, letsimpltop :: Transform +-- Put the "in ..." value of a let in its own binding, but not when the +-- expression is applicable (to prevent loops with inlinefun). +letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do + local_var <- Trans.lift $ is_local_var res + if not local_var + then do + -- If the result is not a local var already (to prevent loops with + -- ourselves), extract it. + id <- mkInternalVar "foo" (CoreUtils.exprType res) + let bind = (id, res) + change $ Let (Rec (bind:binds)) (Var id) + else + -- If the result is already a local var, don't extract it. + return expr + +-- Leave all other expressions unchanged +letsimpl expr = return expr +-- Perform this transform everywhere +letsimpltop = everywhere ("letsimpl", letsimpl) + +-------------------------------- +-- let flattening +-------------------------------- +letflat, letflattop :: Transform +letflat (Let (Rec binds) expr) = do + -- Turn each binding into a list of bindings (possibly containing just one + -- element, of course) + bindss <- Monad.mapM flatbind binds + -- Concat all the bindings + let binds' = concat bindss + -- Return the new let. We don't use change here, since possibly nothing has + -- changed. If anything has changed, flatbind has already flagged that + -- change. + return $ Let (Rec binds') expr + where + -- Turns a binding of a let into a multiple bindings, or any other binding + -- into a list with just that binding + flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)] + flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds) + flatbind (b, expr) = return [(b, expr)] +-- Leave all other expressions unchanged +letflat expr = return expr +-- Perform this transform everywhere +letflattop = everywhere ("letflat", letflat) + +-------------------------------- +-- Simple let binding removal +-------------------------------- +-- Remove a = b bindings from let expressions everywhere +letremovetop :: Transform +letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e)) + +-------------------------------- +-- Function inlining +-------------------------------- +-- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let +-- expressions everywhere. This means that any value that still needs to be +-- applied to something else (polymorphic values need to be applied to a +-- Type) will be inlined, and will eventually be applied to all their +-- arguments. +-- +-- This is a tricky function, which is prone to create loops in the +-- transformations. To fix this, we make sure that no transformation will +-- create a new let binding with a function type. These other transformations +-- will just not work on those function-typed values at first, but the other +-- transformations (in particular β-reduction) should make sure that the type +-- of those values eventually becomes primitive. +inlinenonreptop :: Transform +inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd)) + +-------------------------------- +-- Scrutinee simplification +-------------------------------- +scrutsimpl,scrutsimpltop :: Transform +-- Don't touch scrutinees that are already simple +scrutsimpl expr@(Case (Var _) _ _ _) = return expr +-- Replace all other cases with a let that binds the scrutinee and a new +-- simple scrutinee, but not when the scrutinee is applicable (to prevent +-- loops with inlinefun, though I don't think a scrutinee can be +-- applicable...) +scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do + id <- mkInternalVar "scrut" (CoreUtils.exprType scrut) + change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts) +-- Leave all other expressions unchanged +scrutsimpl expr = return expr +-- Perform this transform everywhere +scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl) + +-------------------------------- +-- Case binder wildening +-------------------------------- +casewild, casewildtop :: Transform +casewild expr@(Case scrut b ty alts) = do + (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts + let bindings = concat bindingss + -- Replace the case with a let with bindings and a case + let newlet = (Let (Rec bindings) (Case scrut b ty alts')) + -- If there are no non-wild binders, or this case is already a simple + -- selector (i.e., a single alt with exactly one binding), already a simple + -- selector altan no bindings (i.e., no wild binders in the original case), + -- don't change anything, otherwise, replace the case. + if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet + where + -- Generate a single wild binder, since they are all the same + wild = MkCore.mkWildBinder + -- Wilden the binders of one alt, producing a list of bindings as a + -- sideeffect. + doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt) + doalt (con, bndrs, expr) = do + bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..] + let bindings = Maybe.catMaybes bindings_maybe + -- We replace the binders with wild binders only. We can leave expr + -- unchanged, since the new bindings bind the same vars as the original + -- did. + let newalt = (con, wildbndrs, expr) + return (bindings, newalt) + where + -- Make all binders wild + wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs + -- A set of all the binders that are used by the expression + free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr + -- Creates a case statement to retrieve the ith element from the scrutinee + -- and binds that to b. + mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr)) + mkextracts b i = + if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b) + -- Don't create extra bindings for binders that are already wild + -- (e.g. not in the free variables of expr, so unused), or for + -- binders that bind function types (to prevent loops with + -- inlinefun). + then return Nothing + else do + -- Create on new binder that will actually capture a value in this + -- case statement, and return it + let bty = (Id.idType b) + id <- mkInternalVar "sel" bty + let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs + return $ Just (b, Case scrut b bty [(con, binders, Var id)]) +-- Leave all other expressions unchanged +casewild expr = return expr +-- Perform this transform everywhere +casewildtop = everywhere ("casewild", casewild) + +-------------------------------- +-- Case value simplification +-------------------------------- +casevalsimpl, casevalsimpltop :: Transform +casevalsimpl expr@(Case scrut b ty alts) = do + -- Try to simplify each alternative, resulting in an optional binding and a + -- new alternative. + (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts + let bindings = Maybe.catMaybes bindings_maybe + -- Create a new let around the case, that binds of the cases values. + let newlet = Let (Rec bindings) (Case scrut b ty alts') + -- If there were no values that needed and allowed simplification, don't + -- change the case. + if null bindings then return expr else change newlet + where + doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt) + -- Don't simplify values that are already simple + doalt alt@(con, bndrs, Var _) = return (Nothing, alt) + -- Simplify each alt by creating a new id, binding the case value to it and + -- replacing the case value with that id. Only do this when the case value + -- does not use any of the binders bound by this alternative, for that would + -- cause those binders to become unbound when moving the value outside of + -- the case statement. Also, don't create a binding for applicable + -- expressions, to prevent loops with inlinefun. + doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do + id <- mkInternalVar "caseval" (CoreUtils.exprType expr) + -- We don't flag a change here, since casevalsimpl will do that above + -- based on Just we return here. + return $ (Just (id, expr), (con, bndrs, Var id)) + -- Find if any of the binders are used by expr + where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr + -- Don't simplify anything else + doalt alt = return (Nothing, alt) +-- Leave all other expressions unchanged +casevalsimpl expr = return expr +-- Perform this transform everywhere +casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl) + +-------------------------------- +-- Case removal +-------------------------------- +-- Remove case statements that have only a single alternative and only wild +-- binders. +caseremove, caseremovetop :: Transform +-- Replace a useless case by the value of its single alternative +caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr + -- Find if any of the binders are used by expr + where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr +-- Leave all other expressions unchanged +caseremove expr = return expr +-- Perform this transform everywhere +caseremovetop = everywhere ("caseremove", caseremove) + +-------------------------------- +-- Argument extraction +-------------------------------- +-- Make sure that all arguments of a representable type are simple variables. +appsimpl, appsimpltop :: Transform +-- Simplify all representable arguments. Do this by introducing a new Let +-- that binds the argument and passing the new binder in the application. +appsimpl expr@(App f arg) = do + -- Check runtime representability + repr <- isRepr arg + local_var <- Trans.lift $ is_local_var arg + if repr && not local_var + then do -- Extract representable arguments + id <- mkInternalVar "arg" (CoreUtils.exprType arg) + change $ Let (Rec [(id, arg)]) (App f (Var id)) + else -- Leave non-representable arguments unchanged + return expr +-- Leave all other expressions unchanged +appsimpl expr = return expr +-- Perform this transform everywhere +appsimpltop = everywhere ("appsimpl", appsimpl) + +-------------------------------- +-- Function-typed argument propagation +-------------------------------- +-- Remove all applications to function-typed arguments, by duplication the +-- function called with the function-typed parameter replaced by the free +-- variables of the argument passed in. +argprop, argproptop :: Transform +-- Transform any application of a named function (i.e., skip applications of +-- lambda's). Also skip applications that have arguments with free type +-- variables, since we can't inline those. +argprop expr@(App _ _) | is_var fexpr = do + -- Find the body of the function called + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + Just body -> do + -- Process each of the arguments in turn + (args', changed) <- Writer.listen $ mapM doarg args + -- See if any of the arguments changed + case Monoid.getAny changed of + True -> do + let (newargs', newparams', oldargs) = unzip3 args' + let newargs = concat newargs' + let newparams = concat newparams' + -- Create a new body that consists of a lambda for all new arguments and + -- the old body applied to some arguments. + let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) + -- Create a new function with the same name but a new body + newf <- mkFunction f newbody + -- Replace the original application with one of the new function to the + -- new arguments. + change $ MkCore.mkCoreApps (Var newf) newargs + False -> + -- Don't change the expression if none of the arguments changed + return expr + + -- If we don't have a body for the function called, leave it unchanged (it + -- should be a primitive function then). + Nothing -> return expr + where + -- Find the function called and the arguments + (fexpr, args) = collectArgs expr + Var f = fexpr + + -- Process a single argument and return (args, bndrs, arg), where args are + -- the arguments to replace the given argument in the original + -- application, bndrs are the binders to include in the top-level lambda + -- in the new function body, and arg is the argument to apply to the old + -- function body. + doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr) + doarg arg = do + repr <- isRepr arg + bndrs <- Trans.lift getGlobalBinders + let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs) + if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) + then do + -- Propagate all complex arguments that are not representable, but not + -- arguments with free type variables (since those would require types + -- not known yet, which will always be known eventually). + -- Find interesting free variables, each of which should be passed to + -- the new function instead of the original function argument. + -- + -- Interesting vars are those that are local, but not available from the + -- top level scope (functions from this module are defined as local, but + -- they're not local to this function, so we can freely move references + -- to them into another function). + let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg + -- Mark the current expression as changed + setChanged + return (map Var free_vars, free_vars, arg) + else do + -- Representable types will not be propagated, and arguments with free + -- type variables will be propagated later. + -- TODO: preserve original naming? + id <- mkBinderFor arg "param" + -- Just pass the original argument to the new function, which binds it + -- to a new id and just pass that new id to the old function body. + return ([arg], [id], mkReferenceTo id) +-- Leave all other expressions unchanged +argprop expr = return expr +-- Perform this transform everywhere +argproptop = everywhere ("argprop", argprop) + +-------------------------------- +-- Function-typed argument extraction +-------------------------------- +-- This transform takes any function-typed argument that cannot be propagated +-- (because the function that is applied to it is a builtin function), and +-- puts it in a brand new top level binder. This allows us to for example +-- apply map to a lambda expression This will not conflict with inlinefun, +-- since that only inlines local let bindings, not top level bindings. +funextract, funextracttop :: Transform +funextract expr@(App _ _) | is_var fexpr = do + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + -- We don't have a function body for f, so we can perform this transform. + Nothing -> do + -- Find the new arguments + args' <- mapM doarg args + -- And update the arguments. We use return instead of changed, so the + -- changed flag doesn't get set if none of the args got changed. + return $ MkCore.mkCoreApps fexpr args' + -- We have a function body for f, leave this application to funprop + Just _ -> return expr + where + -- Find the function called and the arguments + (fexpr, args) = collectArgs expr + Var f = fexpr + -- Change any arguments that have a function type, but are not simple yet + -- (ie, a variable or application). This means to create a new function + -- for map (\f -> ...) b, but not for map (foo a) b. + -- + -- We could use is_applicable here instead of is_fun, but I think + -- arguments to functions could only have forall typing when existential + -- typing is enabled. Not sure, though. + doarg arg | not (is_simple arg) && is_fun arg = do + -- Create a new top level binding that binds the argument. Its body will + -- be extended with lambda expressions, to take any free variables used + -- by the argument expression. + let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg + let body = MkCore.mkCoreLams free_vars arg + id <- mkBinderFor body "fun" + Trans.lift $ addGlobalBind id body + -- Replace the argument with a reference to the new function, applied to + -- all vars it uses. + change $ MkCore.mkCoreApps (Var id) (map Var free_vars) + -- Leave all other arguments untouched + doarg arg = return arg + +-- Leave all other expressions unchanged +funextract expr = return expr +-- Perform this transform everywhere +funextracttop = everywhere ("funextract", funextract) + +-------------------------------- +-- End of transformations +-------------------------------- + + + + +-- What transforms to run? +transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop] + +-- Turns the given bind into VHDL +normalizeModule :: + HscTypes.HscEnv + -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use + -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module) + -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings) + -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful + -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL + +normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do + -- Put all the bindings in this module in the tsBindings map + putA tsBindings (Map.fromList bindings) + -- (Recursively) normalize each of the requested bindings + mapM normalizeBind generate_for + -- Get all initial bindings and the ones we produced + bindings_map <- getA tsBindings + let bindings = Map.assocs bindings_map + normalized_bindings <- getA tsNormalized + typestate <- getA tsType + -- But return only the normalized bindings + return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate) + +normalizeBind :: CoreBndr -> TransformSession () +normalizeBind bndr = + -- Don't normalize global variables, these should be either builtin + -- functions or data constructors. + Monad.when (Var.isLocalId bndr) $ do + -- Skip binders that have a polymorphic type, since it's impossible to + -- create polymorphic hardware. + if is_poly (Var bndr) + then + -- This should really only happen at the top level... TODO: Give + -- a different error if this happens down in the recursion. + error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" + else do + normalized_funcs <- getA tsNormalized + -- See if this function was normalized already + if VarSet.elemVarSet bndr normalized_funcs + then + -- Yup, don't do it again + return () + else do + -- Nope, note that it has been and do it. + modA tsNormalized (flip VarSet.extendVarSet bndr) + expr_maybe <- getGlobalBind bndr + case expr_maybe of + Just expr -> do + -- Introduce an empty Let at the top level, so there will always be + -- a let in the expression (none of the transformations will remove + -- the last let). + let expr' = Let (Rec []) expr + -- Normalize this expression + trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return () + expr' <- dotransforms transforms expr' + trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return () + -- And store the normalized version in the session + modA tsBindings (Map.insert bndr expr') + -- Find all vars used with a function type. All of these should be global + -- binders (i.e., functions used), since any local binders with a function + -- type should have been inlined already. + bndrs <- getGlobalBinders + let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr' + let used_funcs = VarSet.varSetElems used_funcs_set + -- Process each of the used functions recursively + mapM normalizeBind used_funcs + return () + -- We don't have a value for this binder. This really shouldn't + -- happen for local id's... + Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!" diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" new file mode 100644 index 0000000..920d28b --- /dev/null +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -0,0 +1,266 @@ +{-# 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 diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" new file mode 100644 index 0000000..56cba91 --- /dev/null +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -0,0 +1,57 @@ +{-# 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 diff --git "a/c\316\273ash/CLasH/Translator/Translator.hs" "b/c\316\273ash/CLasH/Translator/Translator.hs" new file mode 100644 index 0000000..260b1cd --- /dev/null +++ "b/c\316\273ash/CLasH/Translator/Translator.hs" @@ -0,0 +1,372 @@ +module Translator where +import qualified Directory +import qualified System.FilePath as FilePath +import qualified List +import Debug.Trace +import qualified Control.Arrow as Arrow +import GHC hiding (loadModule, sigName) +import CoreSyn +import qualified CoreUtils +import qualified Var +import qualified Type +import qualified TyCon +import qualified DataCon +import qualified HscMain +import qualified SrcLoc +import qualified FastString +import qualified Maybe +import qualified Module +import qualified Data.Foldable as Foldable +import qualified Control.Monad.Trans.State as State +import Name +import qualified Data.Map as Map +import Data.Accessor +import Data.Generics +import NameEnv ( lookupNameEnv ) +import qualified HscTypes +import HscTypes ( cm_binds, cm_types ) +import MonadUtils ( liftIO ) +import Outputable ( showSDoc, ppr, showSDocDebug ) +import GHC.Paths ( libdir ) +import DynFlags ( defaultDynFlags ) +import qualified UniqSupply +import List ( find ) +import qualified List +import qualified Monad + +-- The following modules come from the ForSyDe project. They are really +-- internal modules, so ForSyDe.cabal has to be modified prior to installing +-- ForSyDe to get access to these modules. +import qualified Language.VHDL.AST as AST +import qualified Language.VHDL.FileIO +import qualified Language.VHDL.Ppr as Ppr +-- This is needed for rendering the pretty printed VHDL +import Text.PrettyPrint.HughesPJ (render) + +import TranslatorTypes +import HsValueMap +import Pretty +import Normalize +-- import Flatten +-- import FlattenTypes +import VHDLTypes +import qualified VHDL + +makeVHDL :: String -> String -> Bool -> IO () +makeVHDL filename name stateful = do + -- Load the module + (core, env) <- loadModule filename + -- Translate to VHDL + vhdl <- moduleToVHDL env core [(name, stateful)] + -- Write VHDL to file + let dir = "./vhdl/" ++ name ++ "/" + prepareDir dir + mapM (writeVHDL dir) vhdl + return () + +listBindings :: String -> IO [()] +listBindings filename = do + (core, env) <- loadModule filename + let binds = CoreSyn.flattenBinds $ cm_binds core + mapM (listBinding) binds + +listBinding :: (CoreBndr, CoreExpr) -> IO () +listBinding (b, e) = do + putStr "\nBinder: " + putStr $ show b + putStr "\nExpression: \n" + putStr $ prettyShow e + putStr "\n\n" + putStr $ showSDoc $ ppr e + putStr "\n\n" + putStr $ showSDoc $ ppr $ CoreUtils.exprType e + putStr "\n\n" + +-- | Show the core structure of the given binds in the given file. +listBind :: String -> String -> IO () +listBind filename name = do + (core, env) <- loadModule filename + let [(b, expr)] = findBinds core [name] + putStr "\n" + putStr $ prettyShow expr + putStr "\n\n" + putStr $ showSDoc $ ppr expr + putStr "\n\n" + putStr $ showSDoc $ ppr $ CoreUtils.exprType expr + putStr "\n\n" + +-- | Translate the binds with the given names from the given core module to +-- VHDL. The Bool in the tuple makes the function stateful (True) or +-- stateless (False). +moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] +moduleToVHDL env core list = do + let (names, statefuls) = unzip list + let binds = map fst $ findBinds core names + -- Generate a UniqSupply + -- Running + -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . + -- on the compiler dir of ghc suggests that 'z' is not used to generate a + -- unique supply anywhere. + uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' + -- Turn bind into VHDL + let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) + let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls + let vhdl = VHDL.createDesignFiles typestate normalized_bindings + mapM (putStr . render . Ppr.ppr . snd) vhdl + --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" + return vhdl + where + +-- | Prepares the directory for writing VHDL files. This means creating the +-- dir if it does not exist and removing all existing .vhdl files from it. +prepareDir :: String -> IO() +prepareDir dir = do + -- Create the dir if needed + exists <- Directory.doesDirectoryExist dir + Monad.unless exists $ Directory.createDirectory dir + -- Find all .vhdl files in the directory + files <- Directory.getDirectoryContents dir + let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files + -- Prepend the dirname to the filenames + let abs_to_remove = map (FilePath.combine dir) to_remove + -- Remove the files + mapM_ Directory.removeFile abs_to_remove + +-- | Write the given design file to a file with the given name inside the +-- given dir +writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO () +writeVHDL dir (name, vhdl) = do + -- Find the filename + let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl" + -- Write the file + Language.VHDL.FileIO.writeDesignFile vhdl fname + +-- | Loads the given file and turns it into a core module. +loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv) +loadModule filename = + defaultErrorHandler defaultDynFlags $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + --target <- guessTarget "adder.hs" Nothing + --liftIO (print (showSDoc (ppr (target)))) + --liftIO $ printTarget target + --setTargets [target] + --load LoadAllTargets + --core <- GHC.compileToCoreSimplified "Adders.hs" + core <- GHC.compileToCoreModule filename + env <- GHC.getSession + return (core, env) + +-- | Extracts the named binds from the given module. +findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)] +findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names + +-- | Extract a named bind from the given list of binds +findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr) +findBind binds lookfor = + -- This ignores Recs and compares the name of the bind with lookfor, + -- disregarding any namespaces in OccName and extra attributes in Name and + -- Var. + find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds + +-- | Flattens the given bind into the given signature and adds it to the +-- session. Then (recursively) finds any functions it uses and does the same +-- with them. +-- flattenBind :: +-- HsFunction -- The signature to flatten into +-- -> (CoreBndr, CoreExpr) -- The bind to flatten +-- -> TranslatorState () +-- +-- flattenBind hsfunc bind@(var, expr) = do +-- -- Flatten the function +-- let flatfunc = flattenFunction hsfunc bind +-- -- Propagate state variables +-- let flatfunc' = propagateState hsfunc flatfunc +-- -- Store the flat function in the session +-- modA tsFlatFuncs (Map.insert hsfunc flatfunc') +-- -- Flatten any functions used +-- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc') +-- mapM_ resolvFunc used_hsfuncs + +-- | Decide which incoming state variables will become state in the +-- given function, and which will be propagate to other applied +-- functions. +-- propagateState :: +-- HsFunction +-- -> FlatFunction +-- -> FlatFunction +-- +-- propagateState hsfunc flatfunc = +-- flatfunc {flat_defs = apps', flat_sigs = sigs'} +-- where +-- (olds, news) = unzip $ getStateSignals hsfunc flatfunc +-- states' = zip olds news +-- -- Find all signals used by all sigdefs +-- uses = concatMap sigDefUses (flat_defs flatfunc) +-- -- Find all signals that are used more than once (is there a +-- -- prettier way to do this?) +-- multiple_uses = uses List.\\ (List.nub uses) +-- -- Find the states whose "old state" signal is used only once +-- single_use_states = filter ((`notElem` multiple_uses) . fst) states' +-- -- See if these single use states can be propagated +-- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc) +-- substate_sigs = concat substate_sigss +-- -- Mark any propagated state signals as SigSubState +-- sigs' = map +-- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info)) +-- (flat_sigs flatfunc) + +-- | Propagate the state into a single function application. +-- propagateState' :: +-- [(SignalId, SignalId)] +-- -- ^ TODO +-- -> SigDef -- ^ The SigDef to process. +-- -> ([SignalId], SigDef) +-- -- ^ Any signal ids that should become substates, +-- -- and the resulting application. +-- +-- propagateState' states def = +-- if (is_FApp def) then +-- (our_old ++ our_new, def {appFunc = hsfunc'}) +-- else +-- ([], def) +-- where +-- hsfunc = appFunc def +-- args = appArgs def +-- res = appRes def +-- our_states = filter our_state states +-- -- A state signal belongs in this function if the old state is +-- -- passed in, and the new state returned +-- our_state (old, new) = +-- any (old `Foldable.elem`) args +-- && new `Foldable.elem` res +-- (our_old, our_new) = unzip our_states +-- -- Mark the result +-- zipped_res = zipValueMaps res (hsFuncRes hsfunc) +-- res' = fmap (mark_state (zip our_new [0..])) zipped_res +-- -- Mark the args +-- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc) +-- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args +-- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'} +-- +-- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse +-- mark_state states (id, use) = +-- case lookup id states of +-- Nothing -> use +-- Just state_id -> State state_id + +-- | Returns pairs of signals that should be mapped to state in this function. +-- getStateSignals :: +-- HsFunction -- | The function to look at +-- -> FlatFunction -- | The function to look at +-- -> [(SignalId, SignalId)] +-- -- | TODO The state signals. The first is the state number, the second the +-- -- signal to assign the current state to, the last is the signal +-- -- that holds the new state. +-- +-- getStateSignals hsfunc flatfunc = +-- [(old_id, new_id) +-- | (old_num, old_id) <- args +-- , (new_num, new_id) <- res +-- , old_num == new_num] +-- where +-- sigs = flat_sigs flatfunc +-- -- Translate args and res to lists of (statenum, sigid) +-- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc) +-- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc) + +-- | Find the given function, flatten it and add it to the session. Then +-- (recursively) do the same for any functions used. +-- resolvFunc :: +-- HsFunction -- | The function to look for +-- -> TranslatorState () +-- +-- resolvFunc hsfunc = do +-- flatfuncmap <- getA tsFlatFuncs +-- -- Don't do anything if there is already a flat function for this hsfunc or +-- -- when it is a builtin function. +-- Monad.unless (Map.member hsfunc flatfuncmap) $ do +-- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do +-- -- New function, resolve it +-- core <- getA tsCoreModule +-- -- Find the named function +-- let name = (hsFuncName hsfunc) +-- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name +-- case bind of +-- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module." +-- Just b -> flattenBind hsfunc b + +-- | Translate a top level function declaration to a HsFunction. i.e., which +-- interface will be provided by this function. This function essentially +-- defines the "calling convention" for hardware models. +-- mkHsFunction :: +-- Var.Var -- ^ The function defined +-- -> Type -- ^ The function type (including arguments!) +-- -> Bool -- ^ Is this a stateful function? +-- -> HsFunction -- ^ The resulting HsFunction +-- +-- mkHsFunction f ty stateful= +-- HsFunction hsname hsargs hsres +-- where +-- hsname = getOccString f +-- (arg_tys, res_ty) = Type.splitFunTys ty +-- (hsargs, hsres) = +-- if stateful +-- then +-- let +-- -- The last argument must be state +-- state_ty = last arg_tys +-- state = useAsState (mkHsValueMap state_ty) +-- -- All but the last argument are inports +-- inports = map (useAsPort . mkHsValueMap)(init arg_tys) +-- hsargs = inports ++ [state] +-- hsres = case splitTupleType res_ty of +-- -- Result type must be a two tuple (state, ports) +-- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty +-- then +-- Tuple [state, useAsPort (mkHsValueMap outport_ty)] +-- else +-- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty) +-- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports." +-- in +-- (hsargs, hsres) +-- else +-- -- Just use everything as a port +-- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty) + +-- | Adds signal names to the given FlatFunction +-- nameFlatFunction :: +-- FlatFunction +-- -> FlatFunction +-- +-- nameFlatFunction flatfunc = +-- -- Name the signals +-- let +-- s = flat_sigs flatfunc +-- s' = map nameSignal s in +-- flatfunc { flat_sigs = s' } +-- where +-- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo) +-- nameSignal (id, info) = +-- let hints = nameHints info in +-- let parts = ("sig" : hints) ++ [show id] in +-- let name = concat $ List.intersperse "_" parts in +-- (id, info {sigName = Just name}) +-- +-- -- | Splits a tuple type into a list of element types, or Nothing if the type +-- -- is not a tuple type. +-- splitTupleType :: +-- Type -- ^ The type to split +-- -> Maybe [Type] -- ^ The tuples element types +-- +-- splitTupleType ty = +-- case Type.splitTyConApp_maybe ty of +-- Just (tycon, args) -> if TyCon.isTupleTyCon tycon +-- then +-- Just args +-- else +-- Nothing +-- Nothing -> Nothing + +-- vim: set ts=8 sw=2 sts=2 expandtab: diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" new file mode 100644 index 0000000..1286a41 --- /dev/null +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -0,0 +1,37 @@ +-- +-- 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: diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" new file mode 100644 index 0000000..09abed6 --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" @@ -0,0 +1,61 @@ +{-# 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) ++ "__" diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" new file mode 100644 index 0000000..0c0e1fa --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -0,0 +1,210 @@ +-- | 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 diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" new file mode 100644 index 0000000..9c5038c --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -0,0 +1,44 @@ +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 diff --git "a/c\316\273ash/CLasH/Utils/HsTools.hs" "b/c\316\273ash/CLasH/Utils/HsTools.hs" new file mode 100644 index 0000000..1bad941 --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/HsTools.hs" @@ -0,0 +1,224 @@ +{-# 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 "") 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 diff --git "a/c\316\273ash/CLasH/Utils/Pretty.hs" "b/c\316\273ash/CLasH/Utils/Pretty.hs" new file mode 100644 index 0000000..d88846a --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/Pretty.hs" @@ -0,0 +1,163 @@ +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 diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" new file mode 100644 index 0000000..e9c4a4a --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -0,0 +1,298 @@ +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" diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" new file mode 100644 index 0000000..8dc7a0a --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -0,0 +1,1038 @@ +{-# 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 ) ) + ] diff --git "a/c\316\273ash/CLasH/VHDL/VHDL.hs" "b/c\316\273ash/CLasH/VHDL/VHDL.hs" new file mode 100644 index 0000000..1a8f394 --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/VHDL.hs" @@ -0,0 +1,298 @@ +-- +-- Functions to generate VHDL from FlatFunctions +-- +module VHDL where + +-- Standard modules +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Maybe +import qualified Control.Monad as Monad +import qualified Control.Arrow as Arrow +import qualified Control.Monad.Trans.State as State +import qualified Data.Monoid as Monoid +import Data.Accessor +import Data.Accessor.MonadState as MonadState +import Debug.Trace + +-- ForSyDe +import qualified Language.VHDL.AST as AST + +-- GHC API +import CoreSyn +--import qualified Type +import qualified Name +import qualified Var +import qualified Id +import qualified IdInfo +import qualified TyCon +import qualified DataCon +--import qualified CoreSubst +import qualified CoreUtils +import Outputable ( showSDoc, ppr ) + +-- Local imports +import VHDLTypes +import VHDLTools +import Pretty +import CoreTools +import Constants +import Generate + +createDesignFiles :: + TypeState + -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] + -> [(AST.VHDLId, AST.DesignFile)] + +createDesignFiles init_typestate binds = + (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) : + map (Arrow.second $ AST.DesignFile full_context) units + + where + init_session = VHDLState init_typestate Map.empty + (units, final_session) = + State.runState (createLibraryUnits binds) init_session + tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) + ty_decls = final_session ^. vsType ^. vsTypeDecls + tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def + tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing) + tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) + ieee_context = [ + AST.Library $ mkVHDLBasicId "IEEE", + mkUseAll ["IEEE", "std_logic_1164"], + mkUseAll ["IEEE", "numeric_std"] + ] + full_context = + mkUseAll ["work", "types"] + : (mkUseAll ["work"] + : ieee_context) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls + subProgSpecs = map subProgSpec tyfun_decls + subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec + +-- Create a use foo.bar.all statement. Takes a list of components in the used +-- name. Must contain at least two components +mkUseAll :: [String] -> AST.ContextItem +mkUseAll ss = + AST.Use $ from AST.:.: AST.All + where + base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss) + from = foldl select base_prefix (tail ss) + select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s) + +createLibraryUnits :: + [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] + -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])] + +createLibraryUnits binds = do + entities <- Monad.mapM createEntity binds + archs <- Monad.mapM createArchitecture binds + return $ zipWith + (\ent arch -> + let AST.EntityDec id _ = ent in + (id, [AST.LUEntity ent, AST.LUArch arch]) + ) + entities archs + +-- | Create an entity for a given function +createEntity :: + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function + -> VHDLSession AST.EntityDec -- | The resulting entity + +createEntity (fname, expr) = do + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + args' <- Monad.mapM mkMap args + -- There must be a let at top level + let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr + res' <- mkMap res + let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname + let ent_decl' = createEntityAST vhdl_id args' res' + let AST.EntityDec entity_id _ = ent_decl' + let signature = Entity entity_id args' res' + modA vsSignatures (Map.insert fname signature) + return ent_decl' + where + mkMap :: + --[(SignalId, SignalInfo)] + CoreSyn.CoreBndr + -> VHDLSession Port + -- We only need the vsTypes element from the state + mkMap = (\bndr -> + let + --info = Maybe.fromMaybe + -- (error $ "Signal not found in the name map? This should not happen!") + -- (lookup id sigmap) + -- Assume the bndr has a valid VHDL id already + id = varToVHDLId bndr + ty = Var.varType bndr + error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr + in do + type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty + return (id, type_mark) + ) + + -- | Create the VHDL AST for an entity +createEntityAST :: + AST.VHDLId -- | The name of the function + -> [Port] -- | The entity's arguments + -> Port -- | The entity's result + -> AST.EntityDec -- | The entity with the ent_decl filled in as well + +createEntityAST vhdl_id args res = + AST.EntityDec vhdl_id ports + where + -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. + ports = map (mkIfaceSigDec AST.In) args + ++ [mkIfaceSigDec AST.Out res] + ++ [clk_port] + -- Add a clk port if we have state + clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM + +-- | Create a port declaration +mkIfaceSigDec :: + AST.Mode -- | The mode for the port (In / Out) + -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port + -> AST.IfaceSigDec -- | The resulting port declaration + +mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty + +{- +-- | Generate a VHDL entity name for the given hsfunc +mkEntityId hsfunc = + -- TODO: This doesn't work for functions with multiple signatures! + -- Use a Basic Id, since using extended id's for entities throws off + -- precision and causes problems when generating filenames. + mkVHDLBasicId $ hsFuncName hsfunc +-} + +-- | Create an architecture for a given function +createArchitecture :: + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function + -> VHDLSession AST.ArchBody -- ^ The architecture for this function + +createArchitecture (fname, expr) = do + signaturemap <- getA vsSignatures + let signature = Maybe.fromMaybe + (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!") + (Map.lookup fname signaturemap) + let entity_id = ent_id signature + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + -- There must be a let at top level + let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr + + -- Create signal declarations for all binders in the let expression, except + -- for the output port (that will already have an output port declared in + -- the entity). + sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) + let sig_decs = Maybe.catMaybes $ sig_dec_maybes + + statementss <- Monad.mapM mkConcSm binds + let statements = concat statementss + return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') + where + procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc) + procs' = map AST.CSPSm procs + -- mkSigDec only uses vsTypes from the state + mkSigDec' = mkSigDec + +{- +-- | Looks up all pairs of old state, new state signals, together with +-- the state id they represent. +makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)] +makeStatePairs flatfunc = + [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) + | old_info <- map snd (flat_sigs flatfunc) + , new_info <- map snd (flat_sigs flatfunc) + -- old_info must be an old state (and, because of the next equality, + -- new_info must be a new state). + , Maybe.isJust $ oldStateId $ sigUse old_info + -- And the state numbers must match + , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)] + + -- Replace the second tuple element with the corresponding SignalInfo + --args_states = map (Arrow.second $ signalInfo sigs) args +mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm +mkStateProcSm (num, old, new) = + AST.ProcSm label [clk] [statement] + where + label = mkVHDLExtId $ "state_" ++ (show num) + clk = mkVHDLExtId "clk" + rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge" + wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing] + assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform + rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] + statement = AST.IfSm rising_edge_clk [assign] [] Nothing + +-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo +-- is not named. +getSignalId :: SignalInfo -> AST.VHDLId +getSignalId info = + mkVHDLExtId $ Maybe.fromMaybe + (error $ "Unnamed signal? This should not happen!") + (sigName info) +-} + +mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) +mkSigDec bndr = + if True then do --isInternalSigUse use || isStateSigUse use then do + let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr + type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) + return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) + else + return Nothing + +-- | Transforms a core binding into a VHDL concurrent statement +mkConcSm :: + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process + -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. + + +-- Ignore Cast expressions, they should not longer have any meaning as long as +-- the type works out. +mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) + +-- Simple a = b assignments are just like applications, but without arguments. +-- We can't just generate an unconditional assignment here, since b might be a +-- top level binding (e.g., a function with no arguments). +mkConcSm (bndr, Var v) = do + genApplication (Left bndr) v [] + +mkConcSm (bndr, app@(CoreSyn.App _ _))= do + let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + let valargs = get_val_args (Var.varType f) args + genApplication (Left bndr) f (map Left valargs) + +-- A single alt case must be a selector. This means thee scrutinee is a simple +-- variable, the alternative is a dataalt with a single non-wild binder that +-- is also returned. +mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = + case alt of + (DataAlt dc, bndrs, (Var sel_bndr)) -> do + case List.elemIndex sel_bndr bndrs of + Just i -> do + labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut) + let label = labels!!i + let sel_name = mkSelectedName (varToVHDLName scrut) label + let sel_expr = AST.PrimName sel_name + return [mkUncondAssign (Left bndr) sel_expr] + Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) + + _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) + +-- Multiple case alt are be conditional assignments and have only wild +-- binders in the alts and only variables in the case values and a variable +-- for a scrutinee. We check the constructor of the second alt, since the +-- first is the default case, if there is any. +mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do + scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut + let cond_expr = scrut' AST.:=: (altconToVHDLExpr con) + true_expr <- MonadState.lift vsType $ varToVHDLExpr true + false_expr <- MonadState.lift vsType $ varToVHDLExpr false + return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] + +mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives" +mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee" +mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" new file mode 100644 index 0000000..6e6a0c4 --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -0,0 +1,534 @@ +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 diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" new file mode 100644 index 0000000..8712043 --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" @@ -0,0 +1,103 @@ +-- +-- 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: diff --git "a/c\316\273ash/LICENSE" "b/c\316\273ash/LICENSE" new file mode 100644 index 0000000..23ebcfd --- /dev/null +++ "b/c\316\273ash/LICENSE" @@ -0,0 +1,25 @@ +Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the copyright holder nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git "a/c\316\273ash/c\316\273ash.cabal" "b/c\316\273ash/c\316\273ash.cabal" new file mode 100644 index 0000000..3eb5dca --- /dev/null +++ "b/c\316\273ash/c\316\273ash.cabal" @@ -0,0 +1,24 @@ +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