+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
module CLasH.VHDL.VHDLTools where
-- Standard modules
import qualified Maybe
import qualified Data.Either as Either
import qualified Data.List as List
+import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Control.Monad as Monad
import qualified Control.Arrow as Arrow
import qualified Type
import qualified DataCon
import qualified CoreSubst
+import qualified Outputable
-- Local imports
import CLasH.VHDL.VHDLTypes
import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
[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.
- -> TranslatorSession [AST.AssocElem] -- ^ The resulting port maps
+ -> [AST.AssocElem] -- ^ The resulting port maps
mkAssocElems args res entity =
- -- Create the actual AssocElems
- return $ zipWith mkAssocElem ports sigs
+ arg_maps ++ (Maybe.maybeToList res_map_maybe)
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)
+ res_port_maybe = ent_res entity
+ -- Create an expression of res to map against the output port
+ res_expr = vhdlNameToVHDLExpr res
+ -- Map each of the input ports
+ arg_maps = zipWith mkAssocElem (map fst arg_ports) args
+ -- Map the output port, if present
+ res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
-- | Create an VHDL port -> signal association
mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
where
-- We always have a clock port, so no need to map it anywhere but here
clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+ resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
-----------------------------------------------------------------------------
-- Functions to generate VHDL Exprs
varToVHDLId ::
CoreSyn.CoreBndr
-> AST.VHDLId
-varToVHDLId = mkVHDLExtId . varToString
+varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+ where
+ lowers :: String -> Int
+ lowers xs = length [x | x <- xs, Char.isLower x]
-- Creates a VHDL Name from a binder
varToVHDLName ::
AST.unsafeVHDLExtId $ strip_invalid s
where
-- Allowed characters, taken from ForSyde's mkVHDLExtId
- allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+ 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
-- 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. Returns Nothing when the type is valid, but empty.
-vhdl_ty :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark)
+vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
+ String -> t -> TypeSession (Maybe AST.TypeMark)
vhdl_ty msg ty = do
tm_either <- vhdl_ty_either ty
case tm_either of
-- 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 (Maybe AST.TypeMark))
-vhdl_ty_either ty = do
+vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either tything =
+ case getType tything of
+ Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
+ Just ty -> vhdl_ty_either' ty
+
+vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
+ | otherwise = do
typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
-> TypeSession (Either String (Maybe (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)
+ let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
+ let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+ let ty_def = AST.SubtypeIn unsignedTM (Just range)
return (Right $ Just (ty_id, Right ty_def))
mk_unsigned_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)
- let unsignedshow = mkIntegerShow ty_id
- modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
return (Right $ Just (ty_id, Right ty_def))
mk_signed_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)
- let signedshow = mkIntegerShow ty_id
- modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
return (Right $ Just (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
AST.PrimLit "'>'" )
-mkIntegerShow ::
- AST.TypeMark -- ^ The specific signed
- -> AST.SubProgBody
-mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
- where
- signedPar = AST.unsafeVHDLBasicId "sint"
- showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
- showExpr = AST.ReturnSm (Just $
- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
- where
- signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
-
mkBuiltInShow :: [AST.SubProgBody]
mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
, AST.SubProgBody showBoolSpec [] [showBoolExpr]
+ , AST.SubProgBody showSingedSpec [] [showSignedExpr]
+ , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
+ -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
]
where
- bitPar = AST.unsafeVHDLBasicId "s"
- boolPar = AST.unsafeVHDLBasicId "b"
+ bitPar = AST.unsafeVHDLBasicId "s"
+ boolPar = AST.unsafeVHDLBasicId "b"
+ signedPar = AST.unsafeVHDLBasicId "sint"
+ unsignedPar = AST.unsafeVHDLBasicId "uint"
+ -- naturalPar = AST.unsafeVHDLBasicId "nat"
showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
-- if s = '1' then return "'1'" else return "'0'"
showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
[AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
[]
(Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
+ showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+ showSignedExpr = AST.ReturnSm (Just $
+ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
+ where
+ signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
+ showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
+ showUnsignedExpr = AST.ReturnSm (Just $
+ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
+ where
+ unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
+ -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+ -- showNaturalExpr = AST.ReturnSm (Just $
+ -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+
genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
genExprFCall fName args =
case type_mark_maybe of
Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
Nothing -> return Nothing
+
+-- | Does the given thing have a non-empty type?
+hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TranslatorSession Bool
+hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)
projects / matthijs / master-project / cλash.git / blobdiff