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
-- Local imports
import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
-- 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
+ 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
+ -> 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
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
+ [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
mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
(AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
+-- | Create an aggregate signal
+mkAggregateSignal :: [AST.Expr] -> AST.Expr
+mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
+
mkComponentInst ::
String -- ^ The portmap label
-> AST.VHDLId -- ^ The entity name
-- 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
+ typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
-- No errors
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)])
+ modA tsTypes (Map.insert htype (ty_id, ty_def))
+ modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
return (Right ty_id)
Left err -> return $ Left $
"VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
let ty_def = AST.TDR $ AST.RecordTypeDef elems
let tupshow = mkTupleShow elem_tys ty_id
- modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
return $ Right (ty_id, Left ty_def)
-- There were errors in element types
(errors, _) -> return $ Left $
-- ^ An error message or The typemark created.
mk_vector_ty ty = do
- types_map <- getA vsTypes
- env <- getA vsHscEnv
+ types_map <- getA tsTypes
+ env <- getA tsHscEnv
let (nvec_l, nvec_el) = Type.splitAppTy ty
let (nvec, leng) = Type.splitAppTy nvec_l
let vec_ty = Type.mkAppTy nvec nvec_el
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))])
+ modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+ modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
let vecShowFuns = mkVectorShow el_ty_tm vec_id
- mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType el_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
+ mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
let ty_def = AST.SubtypeIn vec_id (Just range)
return (Right (ty_id, Right ty_def))
-- Could not create element type
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 vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
return (Right (ty_id, Right ty_def))
mk_signed_ty ::
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 vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
+ modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
return (Right (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
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
+ types <- getA tsTypes
-- Assume the type for which we want labels is really translatable
Right htype <- mkHType ty
case Map.lookup htype types of
let name = Name.getOccString (TyCon.tyConName tycon)
Map.lookup name builtin_types
case builtin_ty of
- Just typ ->
+ Just typ ->
return $ Right $ BuiltinType $ prettyShow typ
Nothing ->
case Type.splitTyConApp_maybe ty of
Left _ -> False
Right _ -> True
+
tfp_to_int :: Type.Type -> TypeSession Int
tfp_to_int ty = do
- lens <- getA vsTfpInts
- hscenv <- getA vsHscEnv
+ hscenv <- getA tsHscEnv
+ let norm_ty = normalise_tfp_int hscenv ty
+ case Type.splitTyConApp_maybe norm_ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "Dec" -> do
+ len <- tfp_to_int' ty
+ return len
+ otherwise -> do
+ modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
+ return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+ Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+
+tfp_to_int' :: Type.Type -> TypeSession Int
+tfp_to_int' ty = do
+ lens <- getA tsTfpInts
+ hscenv <- getA tsHscEnv
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))
+ modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
return new_len
mkTupleShow ::
genExprPCall2 entid arg1 arg2 =
AST.ProcCall (AST.NSimple entid) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
-
\ No newline at end of file
+
+mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (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 tsType $ vhdl_ty error_msg (Var.varType bndr)
+ return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ else
+ return Nothing
projects / matthijs / master-project / cλash.git / blobdiff