From: Christiaan Baaij Date: Fri, 3 Jul 2009 09:48:02 +0000 (+0200) Subject: Keys for typemap can now deal with vector lengths based on type operators X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=f2ce393c85a9ccb673f8ba2df12b7c5b649c3a34 Keys for typemap can now deal with vector lengths based on type operators Implementation is very slow, evalCoreExpr has to be run every time we lookup and insert a new vector. --- diff --git a/Adders.hs b/Adders.hs index 6ada7df..9e78fcf 100644 --- a/Adders.hs +++ b/Adders.hs @@ -174,8 +174,8 @@ highordtest = \x -> xand a b = hwand a b -functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit) -functiontest = \v -> let r = (concat v, head v) in r +functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit, TFVec D3 (TFVec D3 Bit)) +functiontest = \v -> let r = (concat v, head v, tail v) in r xhwnot x = hwnot x diff --git a/Generate.hs b/Generate.hs index 55f0156..dfd9fad 100644 --- a/Generate.hs +++ b/Generate.hs @@ -71,16 +71,16 @@ genOperator1' op _ f [arg] = return $ op arg -- | 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 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 @@ -874,40 +874,40 @@ genUnconsVectorFuns elemTM vectorTM = -- builder function. globalNameTable :: NameTable globalNameTable = Map.fromList - [ (exId , (2, genFCall ) ) - , (replaceId , (3, genFCall ) ) - , (headId , (1, genFCall ) ) - , (lastId , (1, genFCall ) ) - , (tailId , (1, genFCall ) ) - , (initId , (1, genFCall ) ) - , (takeId , (2, genFCall ) ) - , (dropId , (2, genFCall ) ) - , (selId , (4, genFCall ) ) - , (plusgtId , (2, genFCall ) ) - , (ltplusId , (2, genFCall ) ) - , (plusplusId , (2, genFCall ) ) + [ (exId , (2, genFCall False ) ) + , (replaceId , (3, genFCall False ) ) + , (headId , (1, genFCall True ) ) + , (lastId , (1, genFCall True ) ) + , (tailId , (1, genFCall False ) ) + , (initId , (1, genFCall False ) ) + , (takeId , (2, genFCall False ) ) + , (dropId , (2, genFCall False ) ) + , (selId , (4, genFCall False ) ) + , (plusgtId , (2, genFCall False ) ) + , (ltplusId , (2, genFCall False ) ) + , (plusplusId , (2, genFCall False ) ) , (mapId , (2, genMap ) ) , (zipWithId , (3, genZipWith ) ) , (foldlId , (3, genFoldl ) ) , (foldrId , (3, genFoldr ) ) , (zipId , (2, genZip ) ) , (unzipId , (1, genUnzip ) ) - , (shiftlId , (2, genFCall ) ) - , (shiftrId , (2, genFCall ) ) - , (rotlId , (1, genFCall ) ) - , (rotrId , (1, genFCall ) ) + , (shiftlId , (2, genFCall False ) ) + , (shiftrId , (2, genFCall False ) ) + , (rotlId , (1, genFCall False ) ) + , (rotrId , (1, genFCall False ) ) , (concatId , (1, genConcat ) ) - , (reverseId , (1, genFCall ) ) + , (reverseId , (1, genFCall False ) ) , (iteratenId , (3, genIteraten ) ) , (iterateId , (2, genIterate ) ) , (generatenId , (3, genGeneraten ) ) , (generateId , (2, genGenerate ) ) - , (emptyId , (0, genFCall ) ) - , (singletonId , (1, genFCall ) ) - , (copynId , (2, genFCall ) ) + , (emptyId , (0, genFCall False ) ) + , (singletonId , (1, genFCall False ) ) + , (copynId , (2, genFCall False ) ) , (copyId , (1, genCopy ) ) - , (lengthTId , (1, genFCall ) ) - , (nullId , (1, genFCall ) ) + , (lengthTId , (1, genFCall False ) ) + , (nullId , (1, genFCall False ) ) , (hwxorId , (2, genOperator2 AST.Xor ) ) , (hwandId , (2, genOperator2 AST.And ) ) , (hworId , (2, genOperator2 AST.Or ) ) diff --git a/VHDLTools.hs b/VHDLTools.hs index 3b49b27..cb4ea74 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -265,12 +265,13 @@ builtin_types = vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark vhdl_ty msg 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 @@ -280,7 +281,7 @@ vhdl_ty msg ty = do case newty_maybe of Just (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" @@ -354,7 +355,7 @@ mk_vector_ty ty = do 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 (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) @@ -362,7 +363,7 @@ 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 (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 (ty_id, ty_def) @@ -386,10 +387,49 @@ getFieldLabels ty = do vhdl_ty error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef types <- getA vsTypes - case Map.lookup (OrdType ty) types of + htype <- mkHType ty + case Map.lookup htype types of Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) 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 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 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) \ No newline at end of file diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 61fb003..4a1b017 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -38,8 +38,14 @@ instance Eq OrdType where instance Ord OrdType where compare (OrdType a) (OrdType b) = Type.tcCmpType a b +data HType = StdType OrdType | + ADTType String [HType] | + VecType Int HType | + BuiltinType String + deriving (Eq, Ord) + -- A map of a Core type to the corresponding type name -type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) +type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -- A map of a vector Core element type and function name to the coressponding -- VHDLId of the function and the function body.