X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=fbe33a7e3ebe56814e4c00a7b187843f8953f593;hb=bf9f8e9e9cfce93ae1e35cf524b371beb34f5010;hp=6e9dbe3527473b0f6f178754930c27b2a9f66aee;hpb=1ccb9c8289bfb3c2701bf62435332b4c94b04169;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 6e9dbe3..fbe33a7 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -10,6 +10,7 @@ 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 @@ -29,6 +30,7 @@ import qualified CoreSubst -- Local imports import CLasH.VHDL.VHDLTypes +import CLasH.Translator.TranslatorTypes import CLasH.Utils.Core.CoreTools import CLasH.Utils.Pretty import CLasH.VHDL.Constants @@ -55,11 +57,11 @@ 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 + 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 @@ -80,10 +82,10 @@ mkAssign dst cond false_expr = 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 @@ -107,6 +109,10 @@ 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]))) +-- | 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 @@ -276,7 +282,7 @@ vhdl_ty msg ty = do -- 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 @@ -296,8 +302,8 @@ vhdl_ty_either ty = do 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" @@ -348,7 +354,7 @@ mk_tycon_ty ty tycon args = 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 $ @@ -371,8 +377,8 @@ mk_vector_ty :: -- ^ 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 @@ -392,10 +398,10 @@ mk_vector_ty ty = do 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 @@ -423,7 +429,7 @@ mk_unsigned_ty ty = do 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 :: @@ -435,7 +441,7 @@ mk_signed_ty ty = do 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, @@ -446,7 +452,7 @@ getFieldLabels ty = do 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 @@ -465,7 +471,7 @@ mkHType ty = do 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 @@ -528,17 +534,34 @@ isReprType ty = do 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 :: @@ -674,4 +697,12 @@ genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm 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