From: Christiaan Baaij Date: Wed, 29 Jul 2009 12:01:41 +0000 (+0200) Subject: We now make a show function for all default datatypes. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=1ccb9c8289bfb3c2701bf62435332b4c94b04169;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git We now make a show function for all default datatypes. We need to figure out how to show custom datatypes in VHDL, for that we will need a string representation for each constructor. --- diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index 21452a9..ad7b39b 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -57,10 +57,10 @@ createDesignFiles init_typestate binds topbind testinput = State.runState (createLibraryUnits binds) init_session (testbench, final_session) = State.runState (createTestBench Nothing testinput topbind) final_session' - tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) + tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)) ty_decls = final_session ^. vsType ^. vsTypeDecls 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_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing) tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", @@ -154,7 +154,7 @@ createEntityAST vhdl_id args res = ++ [mkIfaceSigDec AST.Out res] ++ [clk_port] -- Add a clk port if we have state - clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM + clk_port = AST.IfaceSigDec clockId AST.In std_logicTM -- | Create a port declaration mkIfaceSigDec :: @@ -409,7 +409,7 @@ createOutputProc outs = [clockId] [AST.IfSm clkPred (writeOuts outs) [] Nothing] where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) - eventId + (AST.NSimple $ eventId) Nothing ) `AST.And` (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'") writeOuts :: [AST.VHDLId] -> [AST.SeqSm] @@ -417,12 +417,6 @@ createOutputProc outs = writeOuts [i] = [writeOut i (AST.PrimLit "LF")] writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is writeOut outSig suffix = - genExprFCall2 writeId + genExprPCall2 writeId (AST.PrimName $ AST.NSimple outputId) - (genExprFCall1 showId ((AST.PrimName $ AST.NSimple outSig) AST.:&: suffix)) - genExprFCall2 entid arg1 arg2 = - AST.ProcCall (AST.NSimple entid) $ - map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] - genExprFCall1 entid arg = - AST.PrimFCall $ AST.FCall (AST.NSimple entid) $ - map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg] + ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix) diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index f465d84..66c43a4 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -16,6 +16,8 @@ resetId, clockId :: AST.VHDLId resetId = AST.unsafeVHDLBasicId resetStr clockId = AST.unsafeVHDLBasicId clockStr +integerId :: AST.VHDLId +integerId = AST.unsafeVHDLBasicId "integer" -- | \"types\" identifier typesId :: AST.VHDLId @@ -266,7 +268,7 @@ showIdString :: String showIdString = "show" showId :: AST.VHDLId -showId = AST.unsafeVHDLBasicId showIdString +showId = AST.unsafeVHDLExtId showIdString -- | write function identifier (from std.textio) writeId :: AST.VHDLId @@ -311,3 +313,11 @@ signedTM = AST.unsafeVHDLBasicId "signed" -- | unsigned TypeMark unsignedTM :: AST.TypeMark unsignedTM = AST.unsafeVHDLBasicId "unsigned" + +-- | string TypeMark +stringTM :: AST.TypeMark +stringTM = AST.unsafeVHDLBasicId "string" + +-- | tup VHDLName suffix +tupVHDLSuffix :: AST.VHDLId -> AST.Suffix +tupVHDLSuffix id = AST.SSimple id \ No newline at end of file diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 2c5f2d7..a2f2fb1 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -248,7 +248,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) - let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) + let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res)) let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr else AST.DownRange len_min_expr (AST.PrimLit "0") let gen_scheme = AST.ForGn n_id gen_range @@ -609,10 +609,8 @@ genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements genUnconsVectorFuns elemTM vectorTM = [ (exId, (AST.SubProgBody exSpec [] [exExpr],[])) , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[])) - , (headId, (AST.SubProgBody headSpec [] [headExpr],[])) , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[])) , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[])) - , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[])) , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[])) , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[])) , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[])) @@ -658,7 +656,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1) @@ -667,23 +665,19 @@ genUnconsVectorFuns elemTM vectorTM = AST.PrimName (AST.NSimple aPar) AST.:&: vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1") ((AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) AST.:-: AST.PrimLit "1")) replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) vecSlice init last = AST.PrimName (AST.NSlice (AST.SliceName (AST.NSimple vecPar) (AST.ToRange init last))) - headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM - -- return vec(0); - headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName - (AST.NSimple vecPar) [AST.PrimLit "0"]))) lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM -- return vec(vec'length-1); lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1"]))) initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-2); @@ -693,34 +687,16 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "2")) ])) Nothing -- resAST.:= vec(0 to vec'length-2) initExpr = AST.NSimple resId AST.:= (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "2")) initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM - -- variable res : fsvec_x (0 to vec'length-2); - tailVar = - AST.VarDec resId - (AST.SubtypeIn vectorTM - (Just $ AST.ConstraintIndex $ AST.IndexConstraint - [AST.ToRange (AST.PrimLit "0") - (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: - (AST.PrimLit "2")) ])) - Nothing - -- res AST.:= vec(1 to vec'length-1) - tailExpr = AST.NSimple resId AST.:= (vecSlice - (AST.PrimLit "1") - (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) - AST.:-: AST.PrimLit "1")) - tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to n-1); @@ -746,14 +722,14 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ])) Nothing -- res AST.:= vec(n to vec'length-1) dropExpr = AST.NSimple resId AST.:= (vecSlice (AST.PrimName $ AST.NSimple nPar) (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1")) dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM, @@ -765,7 +741,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))])) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))])) Nothing plusgtExpr = AST.NSimple resId AST.:= ((AST.PrimName $ AST.NSimple aPar) AST.:&: @@ -819,7 +795,7 @@ genUnconsVectorFuns elemTM vectorTM = -- for i res'range loop -- res(i) := vec(f+i*s); -- end loop; - selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign] + selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign] -- res(i) := vec(f+i*s); selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: (AST.PrimName (AST.NSimple iId) AST.:*: @@ -837,7 +813,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))])) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))])) Nothing ltplusExpr = AST.NSimple resId AST.:= ((AST.PrimName $ AST.NSimple vecPar) AST.:&: @@ -853,9 +829,9 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+: + AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+: AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1")])) Nothing plusplusExpr = AST.NSimple resId AST.:= @@ -864,7 +840,7 @@ genUnconsVectorFuns elemTM vectorTM = plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); @@ -874,7 +850,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := a & init(vec) @@ -892,7 +868,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := tail(vec) & a @@ -906,7 +882,7 @@ genUnconsVectorFuns elemTM vectorTM = -- return vec'length = 0 nullExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=: AST.PrimLit "0") rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-1); @@ -916,7 +892,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := last(vec) & init(vec) @@ -940,7 +916,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := tail(vec) & head(vec) @@ -963,24 +939,25 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- for i in 0 to res'range loop -- res(vec'length-i-1) := vec(i); -- end loop; reverseFor = - AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign] + AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign] -- res(vec'length-i-1) := vec(i); reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:= (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $ AST.NSimple iId])) where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) - (mkVHDLBasicId lengthId) Nothing) AST.:-: + (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimName (AST.NSimple iId) AST.:-: (AST.PrimLit "1") -- return res; reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId)) + ----------------------------------------------------------------------------- -- A table of builtin functions diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 8fd9938..6e9dbe3 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -115,7 +115,7 @@ mkComponentInst :: 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 (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk") + clk_port = mkAssocElem clockId (idToVHDLExpr clockId) compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port])) ----------------------------------------------------------------------------- @@ -320,12 +320,12 @@ construct_vhdl_ty ty = do bound <- tfp_to_int (ranged_word_bound_ty ty) mk_natural_ty 0 bound -- Create a custom type from this tycon - otherwise -> mk_tycon_ty tycon args + otherwise -> mk_tycon_ty ty tycon args Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") -- | Create VHDL type for a custom tycon -mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) -mk_tycon_ty tycon args = +mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_tycon_ty ty tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n") @@ -347,6 +347,8 @@ mk_tycon_ty tycon args = let elem_names = concat $ map prettyShow elem_tys 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) return $ Right (ty_id, Left ty_def) -- There were errors in element types (errors, _) -> return $ Left $ @@ -391,7 +393,9 @@ mk_vector_ty ty = 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 vsTypeDecls (\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 let ty_def = AST.SubtypeIn vec_id (Just range) return (Right (ty_id, Right ty_def)) -- Could not create element type @@ -418,6 +422,8 @@ mk_unsigned_ty ty = do let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1) 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) return (Right (ty_id, Right ty_def)) mk_signed_ty :: @@ -428,6 +434,8 @@ mk_signed_ty ty = do let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1) 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) return (Right (ty_id, Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, @@ -531,4 +539,139 @@ tfp_to_int ty = do Nothing -> do let new_len = eval_tfp_int hscenv ty modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len)) - return new_len \ No newline at end of file + return new_len + +mkTupleShow :: + [AST.TypeMark] -- ^ type of each tuple element + -> AST.TypeMark -- ^ type of the tuple + -> AST.SubProgBody +mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr] + where + tupPar = AST.unsafeVHDLBasicId "tup" + showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM + showExpr = AST.ReturnSm (Just $ + AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'") + where + showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $ + map ((genExprFCall showId). + AST.PrimName . + AST.NSelected . + (AST.NSimple tupPar AST.:.:). + tupVHDLSuffix) + (take tupSize recordlabels) + recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] + tupSize = length elemTMs + +mkVectorShow :: + AST.TypeMark -- ^ elemtype + -> AST.TypeMark -- ^ vectype + -> [(String,AST.SubProgBody)] +mkVectorShow elemTM vectorTM = + [ (headId, AST.SubProgBody headSpec [] [headExpr]) + , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet]) + , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet]) + ] + where + vecPar = AST.unsafeVHDLBasicId "vec" + resId = AST.unsafeVHDLBasicId "res" + headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM + -- return vec(0); + headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName + (AST.NSimple vecPar) [AST.PrimLit "0"]))) + vecSlice init last = AST.PrimName (AST.NSlice + (AST.SliceName + (AST.NSimple vecPar) + (AST.ToRange init last))) + tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM + -- variable res : fsvec_x (0 to vec'length-2); + tailVar = + AST.VarDec resId + (AST.SubtypeIn vectorTM + (Just $ AST.ConstraintIndex $ AST.IndexConstraint + [AST.ToRange (AST.PrimLit "0") + (AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: + (AST.PrimLit "2")) ])) + Nothing + -- res AST.:= vec(1 to vec'length-1) + tailExpr = AST.NSimple resId AST.:= (vecSlice + (AST.PrimLit "1") + (AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) + AST.:-: AST.PrimLit "1")) + tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM + doShowId = AST.unsafeVHDLExtId "doshow" + doShowDef = AST.SubProgBody doShowSpec [] [doShowRet] + where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] + stringTM + -- case vec'len is + -- when 0 => return ""; + -- when 1 => return head(vec); + -- when others => return show(head(vec)) & ',' & + -- doshow (tail(vec)); + -- end case; + doShowRet = + AST.CaseSm (AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) + [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"] + [AST.ReturnSm (Just $ AST.PrimLit "\"\"")], + AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] + [AST.ReturnSm (Just $ + genExprFCall showId + (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )], + AST.CaseSmAlt [AST.Others] + [AST.ReturnSm (Just $ + genExprFCall showId + (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&: + AST.PrimLit "','" AST.:&: + genExprFCall doShowId + (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]] + -- return '<' & doshow(vec) & '>'; + showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&: + genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&: + AST.PrimLit "'>'" ) + +mkIntegerShow :: + AST.TypeMark -- ^ The specific signed + -> AST.SubProgBody +mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr] + where + signedPar = AST.unsafeVHDLBasicId "sint" + showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM + showExpr = AST.ReturnSm (Just $ + AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) + (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing ) + where + signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar) + +mkBuiltInShow :: [AST.SubProgBody] +mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] + , AST.SubProgBody showBoolSpec [] [showBoolExpr] + ] + where + bitPar = AST.unsafeVHDLBasicId "s" + boolPar = AST.unsafeVHDLBasicId "b" + 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'") + [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")] + [] + (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")]) + showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM + -- if b then return "True" else return "False" + showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar)) + [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")] + [] + (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")]) + +genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr +genExprFCall fName args = + AST.PrimFCall $ AST.FCall (AST.NSimple fName) $ + map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] + +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