X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=39506f8b5fd571c3f40c63abdb1f7b7036922bfd;hb=8963597a9ec246d8bac113c0ffc05b8192572ed2;hp=ed4d7f6b3bc4608e0a0699102eb576d50c3da642;hpb=ad9bc80c39c42f645c76c65e1d3833148b854c1e;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 ed4d7f6..39506f8 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -1,9 +1,11 @@ +{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason... module CLasH.VHDL.VHDLTools where -- Standard modules import qualified Maybe import qualified Data.Either as Either import qualified Data.List as List +import qualified Data.Char as Char import qualified Data.Map as Map import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow @@ -27,11 +29,13 @@ import qualified TyCon import qualified Type import qualified DataCon import qualified CoreSubst +import qualified Outputable -- Local imports import CLasH.VHDL.VHDLTypes import CLasH.Translator.TranslatorTypes import CLasH.Utils.Core.CoreTools +import CLasH.Utils import CLasH.Utils.Pretty import CLasH.VHDL.Constants @@ -87,28 +91,21 @@ mkAssocElems :: -> Entity -- ^ The entity to map against. -> [AST.AssocElem] -- ^ The resulting port maps mkAssocElems args res entity = - -- Create the actual AssocElems - zipWith mkAssocElem ports sigs + arg_maps ++ (Maybe.maybeToList res_map_maybe) where - -- Turn the ports and signals from a map into a flat list. This works, - -- since the maps must have an identical form by definition. TODO: Check - -- the similar form? arg_ports = ent_args entity - res_port = ent_res entity - -- Extract the id part from the (id, type) tuple - ports = map fst (res_port : arg_ports) - -- Translate signal numbers into names - sigs = (vhdlNameToVHDLExpr res : args) + res_port_maybe = ent_res entity + -- Create an expression of res to map against the output port + res_expr = vhdlNameToVHDLExpr res + -- Map each of the input ports + arg_maps = zipWith mkAssocElem (map fst arg_ports) args + -- Map the output port, if present + res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe -- | Create an VHDL port -> signal association mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) --- | Create an VHDL port -> signal association -mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem -mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName - (AST.NSimple signal) [AST.PrimName $ AST.NSimple index]))) - -- | Create an aggregate signal mkAggregateSignal :: [AST.Expr] -> AST.Expr mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) @@ -187,7 +184,10 @@ dataconToVHDLExpr dc = AST.PrimLit lit varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId -varToVHDLId = mkVHDLExtId . varToString +varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var)) + where + lowers :: String -> Int + lowers xs = length [x | x <- xs, Char.isLower x] -- Creates a VHDL Name from a binder varToVHDLName :: @@ -271,7 +271,8 @@ builtin_types = -- Translate a Haskell type to a VHDL type, generating a new type if needed. -- Returns an error value, using the given message, when no type could be -- created. Returns Nothing when the type is valid, but empty. -vhdl_ty :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark) +vhdl_ty :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession (Maybe AST.TypeMark) vhdl_ty msg ty = do tm_either <- vhdl_ty_either ty case tm_either of @@ -280,8 +281,16 @@ vhdl_ty msg ty = do -- 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 (Maybe AST.TypeMark)) -vhdl_ty_either ty = do +vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) => + t -> TypeSession (Either String (Maybe AST.TypeMark)) +vhdl_ty_either tything = + case getType tything of + Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything + Just ty -> vhdl_ty_either' ty + +vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) +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 @@ -317,6 +326,8 @@ vhdl_ty_either ty = do -- 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 (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) +-- State types don't generate VHDL +construct_vhdl_ty ty | isStateType ty = return $ Right Nothing construct_vhdl_ty ty = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do @@ -439,8 +450,6 @@ 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 tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow) return (Right $ Just (ty_id, Right ty_def)) mk_signed_ty :: @@ -451,8 +460,6 @@ 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 tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow) return (Right $ Just (ty_id, Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, @@ -670,26 +677,19 @@ mkVectorShow elemTM vectorTM = 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] + , AST.SubProgBody showSingedSpec [] [showSignedExpr] + , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr] + , AST.SubProgBody showNaturalSpec [] [showNaturalExpr] ] where - bitPar = AST.unsafeVHDLBasicId "s" - boolPar = AST.unsafeVHDLBasicId "b" + bitPar = AST.unsafeVHDLBasicId "s" + boolPar = AST.unsafeVHDLBasicId "b" + signedPar = AST.unsafeVHDLBasicId "sint" + unsignedPar = AST.unsafeVHDLBasicId "uint" + 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'") @@ -702,6 +702,23 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")] [] (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")]) + showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM + showSignedExpr = 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) + showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM + showUnsignedExpr = AST.ReturnSm (Just $ + AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) + (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 ) + genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr genExprFCall fName args = @@ -720,3 +737,8 @@ mkSigDec bndr = do case type_mark_maybe of Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) Nothing -> return Nothing + +-- | Does the given thing have a non-empty type? +hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => + t -> TranslatorSession Bool +hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)