From: Matthijs Kooijman Date: Fri, 3 Jul 2009 11:27:57 +0000 (+0200) Subject: Merge git://github.com/darchon/clash into cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=c8034ff49822eb6e0e0696f288e20e49a1b9af6e;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge git://github.com/darchon/clash into cλash * git://github.com/darchon/clash: Keys for typemap can now deal with vector lengths based on type operators Conflicts: Generate.hs VHDLTools.hs --- c8034ff49822eb6e0e0696f288e20e49a1b9af6e diff --cc Generate.hs index 6b19bb5,dfd9fad..b3045de --- a/Generate.hs +++ b/Generate.hs @@@ -72,16 -71,16 +72,16 @@@ genOperator1' op _ f [arg] = return $ o -- | Generate a function call from the destination binder, function name and a -- list of expressions (its arguments) - genFCall :: BuiltinBuilder - genFCall = genExprArgs $ genExprRes genFCall' - genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr - genFCall' (Left res) f args = do + 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 = (tfvec_elem . Var.varType) res + let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res) - id <- vectorFunId el_ty fname + 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 + genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder diff --cc VHDLTools.hs index 5deaf45,cb4ea74..d560a74 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@@ -263,46 -262,33 +263,47 @@@ builtin_types ] -- Translate a Haskell type to a VHDL type, generating a new type if needed. -vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark +-- 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 <- mkHType ty 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 (OrdType ty) typemap + 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 t + Just t -> return (Right t) -- No type yet, try to construct it Nothing -> do - newty_maybe <- (construct_vhdl_ty msg ty) + newty_maybe <- (construct_vhdl_ty ty) case newty_maybe of - Just (ty_id, ty_def) -> do + Right (ty_id, ty_def) -> do -- TODO: Check name uniqueness - modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def)) + modA vsTypes (Map.insert htype (ty_id, ty_def)) modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) - return ty_id - Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" - --- Construct a new VHDL type for the given Haskell type. -construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) -construct_vhdl_ty msg ty = do + return (Right ty_id) + Left err -> return $ Left $ + "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" + ++ 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) @@@ -368,28 -351,22 +369,28 @@@ mk_vector_ty ty = d let vec_ty = Type.mkAppTy nvec nvec_el let len = tfvec_len ty let el_ty = tfvec_elem ty - let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty - el_ty_tm <- vhdl_ty error_msg el_ty - 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 (ty_id, 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 (ty_id, ty_def) + 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 (OrdType vec_ty) types_map ++ 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 (OrdType vec_ty) (vec_id, (Left vec_def))) ++ 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) @@@ -418,3 -395,41 +420,41 @@@ getFieldLabels ty = d 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 -> VHDLSession HType ++mkHType :: Type.Type -> TypeSession 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 $ 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 + elem_htype <- mkHType (tfvec_elem ty) + return $ VecType (tfvec_len ty) elem_htype + otherwise -> do + mkTyConHType tycon args + Nothing -> return $ StdType $ OrdType ty + + -- FIXME: Do we really need to do this here again? -mkTyConHType :: TyCon.TyCon -> [Type.Type] -> VHDLSession HType ++mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType + mkTyConHType tycon args = + case TyCon.tyConDataCons tycon of + -- Not an algebraic type + [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon + [dc] -> do + let arg_tys = DataCon.dataConRepArgTys dc + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + elem_htys <- mapM mkHType real_arg_tys + return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys + dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon + where + tyvars = TyCon.tyConTyVars tycon - subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) ++ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)