X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=a40ad00311c7bf5338f7c5537e98422feb48ba3f;hb=acdf6e104979ff6354caeecf73eef680ea9369e4;hp=b2f166e046c77bd51638ea5d13dd42713f376306;hpb=a5a073e51209d741f9c7d2323df8e2c4571e86e6;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index b2f166e..a40ad00 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -63,6 +63,9 @@ createDesignFiles binds = tyfun_decls = Map.elems (final_session ^.vsTypeFuns) ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes) vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes)) + tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def + tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing) + tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@ -71,7 +74,7 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (vec_decls ++ ty_decls ++ subProgSpecs) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs) type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) subProgSpecs = concat (map subProgSpec tyfun_decls) subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) @@ -274,10 +277,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do --let valargs = filter isValArg args in if all is_var valargs then do labels <- getFieldLabels (CoreUtils.exprType app) - let assigns = zipWith mkassign labels valargs - let block_id = bndrToVHDLId bndr - let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns - return [AST.CSBSm block] + return $ zipWith mkassign labels valargs else error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args where @@ -289,18 +289,31 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do -- It's a global value imported from elsewhere. These can be builtin -- functions. funSignatures <- getA vsNameTable + entSignatures <- getA vsSignatures case (Map.lookup (bndrToString f) funSignatures) of Just (arg_count, builder) -> if length valargs == arg_count then - let - sigs = map (bndrToString.varBndr) valargs - sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs - func = builder sigsNames - src_wform = AST.Wform [AST.WformElem func Nothing] - dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) - assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - in - return [AST.CSSASm assign] + case builder of + Left funBuilder -> + let + sigs = map (bndrToString.varBndr) valargs + sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs + func = funBuilder sigsNames + src_wform = AST.Wform [AST.WformElem func Nothing] + dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) + assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) + in + return [AST.CSSASm assign] + Right genBuilder -> + let + sigs = map (varBndr) valargs + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!") + (Map.lookup (head sigs) entSignatures) + arg_name = mkVHDLExtId (bndrToString (last sigs)) + dst_name = mkVHDLExtId (bndrToString bndr) + genSm = genBuilder 4 signature [arg_name, dst_name] + in return [AST.CSGSm genSm] else error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f @@ -313,20 +326,16 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") (Map.lookup f signatures) entity_id = ent_id signature - label = bndrToString bndr + label = "comp_ins_" ++ bndrToString bndr -- Add a clk port if we have state --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" + clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) - portmaps = mkAssocElems args bndr signature + portmaps = clk_port : mkAssocElems args bndr signature in return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)] details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details --- GHC generates some funny "r = r" bindings in let statements before --- simplification. This outputs some dummy ConcSM for these, so things will at --- least compile for now. -mkConcSm (bndr, CoreSyn.Var _) = return [AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []] - -- A single alt case must be a selector. This means thee scrutinee is a simple -- variable, the alternative is a dataalt with a single non-wild binder that -- is also returned. @@ -575,13 +584,13 @@ construct_vhdl_ty ty = do let name = Name.getOccString (TyCon.tyConName tycon) case name of "TFVec" -> do - res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) ty + res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) return $ Just $ (Arrow.second Right) res -- "SizedWord" -> do -- res <- mk_vector_ty (sized_word_len ty) ty -- return $ Just $ (Arrow.second Left) res "RangedWord" -> do - res <- mk_natural_ty 0 (ranged_word_bound ty) ty + res <- mk_natural_ty 0 (ranged_word_bound ty) return $ Just $ (Arrow.second Right) res -- Create a custom type from this tycon otherwise -> mk_tycon_ty tycon args @@ -620,10 +629,9 @@ mk_tycon_ty tycon args = mk_vector_ty :: Int -- ^ The length of the vector -> Type.Type -- ^ The Haskell element type of the Vector - -> Type.Type -- ^ The Haskell type to create a VHDL type for -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created. -mk_vector_ty len el_ty ty = do +mk_vector_ty len el_ty = do elem_types_map <- getA vsElemTypes el_ty_tm <- vhdl_ty el_ty let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) @@ -635,24 +643,22 @@ mk_vector_ty len el_ty ty = do return (ty_id, ty_def) Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) - let vec_def = AST.TDA $ AST.UnconsArrayDef [naturalTM] el_ty_tm + let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def)) - modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id)) + modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) let ty_def = AST.SubtypeIn vec_id (Just range) return (ty_id, ty_def) mk_natural_ty :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> Type.Type -- ^ The Haskell type to create a VHDL type for -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created. -mk_natural_ty min_bound max_bound ty = do +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) return (ty_id, ty_def) - - + builtin_types = Map.fromList [ ("Bit", std_logic_ty),