X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=785b528afb1140db80655c62a7346b6a3bdc2f88;hb=cf39807bf7b8424b6db0bc07a922a19972786735;hp=0d95f55425c90ec9198a93bd1dbc46ee2a108b2c;hpb=cba006ca253e6fcb39c0a82022e9704672997d3a;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 0d95f55..785b528 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -73,7 +73,7 @@ mkAssign dst cond false_expr = whenelse = case cond of Just (cond_expr, true_expr) -> let - true_wform = AST.Wform [AST.WformElem true_expr Nothing] + true_wform = AST.Wform [AST.WformElem true_expr Nothing] in [AST.WhenElse true_wform cond_expr] Nothing -> [] @@ -85,6 +85,31 @@ mkAssign dst cond false_expr = in AST.CSSASm assign +mkAltsAssign :: + Either CoreBndr AST.VHDLName -- ^ The signal to assign to + -> [AST.Expr] -- ^ The conditions + -> [AST.Expr] -- ^ The expressions + -> AST.ConcSm -- ^ The Alt assigns +mkAltsAssign dst conds exprs + | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch" + | otherwise = + let + whenelses = zipWith mkWhenElse conds exprs + false_wform = AST.Wform [AST.WformElem (last exprs) Nothing] + dst_name = case dst of + Left bndr -> AST.NSimple (varToVHDLId bndr) + Right name -> name + assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing) + in + AST.CSSASm assign + where + mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse + mkWhenElse cond true_expr = + let + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + in + AST.WhenElse true_wform cond + mkAssocElems :: [AST.Expr] -- ^ The argument that are applied to function -> AST.VHDLName -- ^ The binder in which to store the result @@ -119,7 +144,8 @@ 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 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 @@ -128,7 +154,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins varToVHDLExpr :: Var.Var -> TypeSession AST.Expr varToVHDLExpr var = do case Id.isDataConWorkId_maybe var of - Just dc -> return $ dataconToVHDLExpr dc + Just dc -> dataconToVHDLExpr dc -- This is a dataconstructor. -- Not a datacon, just another signal. Perhaps we should check for -- local/global here as well? @@ -158,23 +184,37 @@ 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 :: CoreSyn.AltCon -> TypeSession 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!" +altconToVHDLExpr DEFAULT = return $ AST.PrimLit "undefined" -- 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" +dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr +dataconToVHDLExpr dc = do + typemap <- getA tsTypes + htype_either <- mkHType (DataCon.dataConRepType dc) + case htype_either of + -- No errors + Right htype -> do + let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap + case existing_ty of + Just ty -> do + let dcname = DataCon.dataConName dc + let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname + return lit + Nothing -> do + let tycon = DataCon.dataConTyCon dc + let tyname = TyCon.tyConName tycon + let dcname = DataCon.dataConName dc + let 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" + return $ AST.PrimLit lit + -- Error when constructing htype + Left err -> error err ----------------------------------------------------------------------------- -- Functions dealing with names, variables and ids @@ -238,7 +278,7 @@ mkVHDLExtId s = 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 @@ -289,7 +329,8 @@ vhdl_ty_either tything = Just ty -> vhdl_ty_either' ty vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either' ty = do +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 @@ -378,7 +419,19 @@ mk_tycon_ty ty tycon args = (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" + dcs -> do + let arg_tys = concat $ map DataCon.dataConRepArgTys dcs + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + case real_arg_tys of + [] -> do + let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs + let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) + let ty_def = AST.TDE $ AST.EnumTypeDef elems + let enumShow = mkEnumShow elems ty_id + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow) + return $ Right $ Just (ty_id, Left ty_def) + xs -> return $ Left $ + "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\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 @@ -436,9 +489,10 @@ mk_natural_ty :: -> 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 :: @@ -526,7 +580,7 @@ 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" + [] -> return $ Left $ "VHDLTools.mkTyConHType: 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 @@ -537,9 +591,16 @@ mkTyConHType tycon args = 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" + "VHDLTools.mkTyConHType: 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" + dcs -> do + let arg_tys = concat $ map DataCon.dataConRepArgTys dcs + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + case real_arg_tys of + [] -> + return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) + xs -> return $ Left $ + "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" where tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) @@ -606,6 +667,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr] recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] tupSize = length elemTMs +mkEnumShow :: + [AST.VHDLId] + -> AST.TypeMark + -> AST.SubProgBody +mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr] + where + enumPar = AST.unsafeVHDLBasicId "enum" + showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM + showExpr = AST.ReturnSm (Just $ + AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM)) + mkVectorShow :: AST.TypeMark -- ^ elemtype -> AST.TypeMark -- ^ vectype @@ -681,14 +753,14 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] , AST.SubProgBody showBoolSpec [] [showBoolExpr] , AST.SubProgBody showSingedSpec [] [showSignedExpr] , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr] - , AST.SubProgBody showNaturalSpec [] [showNaturalExpr] + -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr] ] where bitPar = AST.unsafeVHDLBasicId "s" boolPar = AST.unsafeVHDLBasicId "b" signedPar = AST.unsafeVHDLBasicId "sint" unsignedPar = AST.unsafeVHDLBasicId "uint" - naturalPar = AST.unsafeVHDLBasicId "nat" + -- 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'") @@ -713,10 +785,10 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] (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 ) + -- 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