From 49532f46ce5a1316a6971f1cf033b61daf7e0e3b Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Wed, 31 Jul 2024 17:34:54 -0700 Subject: [PATCH 01/43] Initial, hacky work on computing wrapper interface method types using type classes --- src/Libraries/Base1/Prelude.bs | 112 ++++++++++++++++++++++- src/comp/GenWrap.hs | 160 ++++++++++----------------------- src/comp/PreIds.hs | 5 ++ src/comp/PreStrings.hs | 3 + 4 files changed, 167 insertions(+), 113 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 5c379d024..6dffeeabc 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -253,7 +253,10 @@ package Prelude( -- Generics Generic(..), Conc(..), ConcPrim(..), ConcPoly(..), Meta(..), MetaData(..), StarArg(..), NumArg(..), StrArg(..), ConArg(..), - MetaConsNamed(..), MetaConsAnon(..), MetaField(..) + MetaConsNamed(..), MetaConsAnon(..), MetaField(..), + + Curry(..), AppendTuple(..), AppendTuple'(..), + WrapPorts(..), WrapMethod(..) ) where infixr 0 $ @@ -4370,3 +4373,110 @@ data (MetaConsAnon :: $ -> # -> # -> *) name idx nfields = MetaConsAnon -- field) and index in the constructor's fields data (MetaField :: $ -> # -> *) name idx = MetaField deriving (FShow) + + +class Curry f g | f -> g where + curryN :: f -> g + uncurryN :: g -> f + +instance (Curry (b -> c) d) => Curry ((a, b) -> c) (a -> d) where + curryN f x = curryN $ \y -> f (x, y) + uncurryN f (x, y) = uncurryN (f x) y + +instance Curry (() -> a) a where + curryN f = f () + uncurryN f _ = f + +instance Curry (a -> b) (a -> b) where + curryN = id + uncurryN = id + +class AppendTuple a b c | a b -> c where + appendTuple :: a -> b -> c + +instance AppendTuple a () a where + appendTuple x _ = x + +-- The above instance should take precedence over the other cases that assume +-- b is non-unit. To avoid overlapping instances, the below are factored out as +-- a seperate type class: +instance (AppendTuple' a b c) => AppendTuple a b c where + appendTuple = appendTuple' + +class AppendTuple' a b c | a b -> c where + appendTuple' :: a -> b -> c + +instance AppendTuple' () a a where + appendTuple' _ = id + +instance AppendTuple' a b (a, b) where + appendTuple' a b = (a, b) + +instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where + appendTuple' (x, y) z = (x, appendTuple' y z) + + +data (WrapPort :: $ -> # -> *) name n = WrapPort (Bit n) + +class WrapPorts a p | a -> p where + toPorts :: a -> p + fromPorts :: p -> a + +{- +instance (Bits a n) => WrapPorts a (WrapPort "foo" n) where + toPorts = WrapPort ∘ pack + fromPorts (WrapPort x) = unpack x +-} + +instance (Bits a n) => WrapPorts a (Bit n) where + toPorts = pack + fromPorts = unpack + +{- +instance WrapPorts (Vector 0 a) () where + toPorts _ = () + fromPorts _ = nil + +instance (Add n1 1 n, WrapPorts a p1, WrapPorts (Vector n1 a) p2, AppendTuple p1 p2 p) => + WrapPorts (Vector n a) p where + toPorts v = appendTuple (toPorts $ head v) (toPorts $ tail v) +-} + +-- TODO: If there is only one instance for WrapPorts, the first WrapMethod instance below fails to typecheck. +instance WrapPorts () () where + toPorts = id + fromPorts = id + +class WrapMethod m w | m -> w where + toWrapMethod :: m -> w + fromWrapMethod :: w -> m + +instance (WrapPorts a p, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where + toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ fromPorts + fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts + +instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where + toWrapMethod = toActionValue_ + fromWrapMethod = fromActionValue_ + +instance (Bits a n) => WrapMethod a (Bit n) where + toWrapMethod = pack + fromWrapMethod = unpack + +-- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, +-- but this case was being handled in GenWrap. +instance WrapMethod PrimAction PrimAction where + toWrapMethod = id + fromWrapMethod = id + +instance WrapMethod Clock Clock where + toWrapMethod = id + fromWrapMethod = id + +instance WrapMethod Reset Reset where + toWrapMethod = id + fromWrapMethod = id + +instance (Bits a n) => WrapMethod (Inout a) (Inout_ n) where + toWrapMethod = primInoutCast0 + fromWrapMethod = primInoutUncast0 diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index f2b61dc1e..0c7278acd 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -825,17 +825,11 @@ genTDef trec@(IfcTRec newId rootId _ sty _ k fts args _) = (ifc',newprops) <- genIfc trec args k --traceM( "genTDef: ifc " ++ ppReadable ifc' ) --traceM( "genTDef:: new prop are: " ++ ppReadable newprops ) - flgs <- getFlags - symt <- getSymTab - let res = cCtxReduceDef flgs symt ifc' - --traceM( "genTDef: res " ++ ppReadable res ) - case res of -- type checking for the interface - Left msgs -> bads msgs - Right ifc'' -> return GeneratedIfc { - genifc_id = newId, - genifc_kind = k, - genifc_cdefn = ifc'', - genifc_pprops = newprops } + return GeneratedIfc { + genifc_id = newId, + genifc_kind = k, + genifc_cdefn = ifc', + genifc_pprops = newprops } -- Generate a new interface definition for the CPackage -- Basically, this consists of a Cstruct of sub-type Sintrface. @@ -889,18 +883,11 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = return ((concat fields), (concat props)) _ -> -- leaf function do - let (v, vs) = unconsOrErr "GenWrap.genIfcField: v:vs" $ - map cTVarNum (take (length argtypes + 1) tmpTyVarIds) - let bitsCtx a s = CPred (CTypeclass idBits) [a, s] - let ctx = zipWith bitsCtx argtypes vs - let ss = map (TAp tBit) vs - isClock <- isClockType rettype isReset <- isResetType rettype isInout <- isInoutType rettype let isIot = isInout/=Nothing isPA <- isPrimAction rettype - isAV <- isActionValue rettype isVec <- isVectorInterfaces rettype case (isVec, argtypes) of (Just (n, tVec, isListN), []) -> @@ -913,37 +900,30 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = let (fields,props) = unzip fieldsprops return (concat fields, concat props) _ -> do -- ELSE NOT a Vec - (r', ctx') <- - if isAV then do - av_t <- getAVType "genIfcField" rettype - return (TAp tActionValue_ v, bitsCtx av_t v : ctx) - else return $ - case isInout of - Just t -> (TAp tInout_ v, - bitsCtx t v : ctx) - _ -> if (isPA || isClock || isReset) then (rettype, ctx) - else (TAp tBit v, bitsCtx rettype v : ctx) - let fi = binId prefixes fieldId - -- - let (mprops, ifcPragmas) = gen prefixes ciPrags fieldId fi - gen | isClock = genNewClockIfcPragmas - | isReset = genNewResetIfcPragmas - | isIot = genNewInoutIfcPragmas - | otherwise = genNewMethodIfcPragmas - - let ifc_field = CField { cf_name = fi, - cf_pragmas = Just ifcPragmas, - cf_type = CQType ctx' (foldr arrow r' ss), - cf_orig_type = Just (foldr arrow rettype argtypes), - cf_default = [] - } - -- - -- the ready field - let rdy_field = if (isClock || isReset || isIot) then [] - else mkReadyField trec ifcPragmas ifcIdIn fieldId fi - -- - --traceM( "ifc_fields is: " ++ ppReadable ifc_field) - return ((ifc_field : rdy_field), mprops ) + let v = cTVar $ head tmpTyVarIds + let ctx = CPred (CTypeclass idWrapMethod) [foldr arrow rettype argtypes, v] + + let fi = binId prefixes fieldId + -- + let (mprops, ifcPragmas) = gen prefixes ciPrags fieldId fi + gen | isClock = genNewClockIfcPragmas + | isReset = genNewResetIfcPragmas + | isIot = genNewInoutIfcPragmas + | otherwise = genNewMethodIfcPragmas + + let ifc_field = CField { cf_name = fi, + cf_pragmas = Just ifcPragmas, + cf_type = CQType [ctx] v, + cf_orig_type = Just (foldr arrow rettype argtypes), + cf_default = [] + } + -- + -- the ready field + let rdy_field = if (isClock || isReset || isIot) then [] + else mkReadyField trec ifcPragmas ifcIdIn fieldId fi + -- + --traceM( "ifc_fields is: " ++ ppReadable ifc_field) + return ((ifc_field : rdy_field), mprops ) -- create a RDY field, if requested @@ -1120,25 +1100,10 @@ genTo pps ty mk = fields <- mapM recurse nums return (concat fields) _ -> do - isClock <- isClockType r - isReset <- isResetType r - isInout <- isInoutType r - isPA <- isPrimAction r - isAV <- isActionValue r - let vs = take (length as) (aIds ++ tmpVarXIds) -- XXX idEmpty is a horrible way to know no more selection is required - let ec = if f == idEmpty then sel else - cApply 11 (CSelect sel (setInternal f)) - (map (\ v -> CApply eUnpack [CVar v]) vs) - let e = - case isInout of - Just _ -> CApply ePrimInoutCast0 [ec] - _ -> if isClock || isReset || isPA - then ec - else if isAV - then cVApply idToActionValue_ [ec] - else CApply ePack [ec] - return [CLValue (binId prefixes f) [CClause (map CPVar vs) [] e] []] + let ec = if f == idEmpty then sel else CSelect sel (setInternal f) + let e = CApply (CVar id_toWrapMethod) [ec] + return [CLValue (binId prefixes f) [CClause [] [] e] []] -- -------------------- -- genWrapE toplevel: mkFrom_ @@ -1153,15 +1118,15 @@ mkFrom_ trec@(IfcTRec { rec_numargs = [], rec_typemap = [] }) = tyId <- flatTypeId pps t let arg = id_t (getPosition t) let ty = cTCon tyId `fn` t - (expr, ctxs) <- genFrom pps t (CVar arg) + expr <- genFrom pps t (CVar arg) let cls = CClause [CPVar arg] [] expr - return (CValueSign (CDef (from_Id tyId) (CQType ctxs ty) [cls])) + return (CValueSign (CDef (from_Id tyId) (CQType [] ty) [cls])) mkFrom_ x = internalError "GenWrap::mkFrom_ " from_Id :: Id -> Id from_Id i = addInternalProp (mkIdPre fsFrom i) -genFrom :: [PProp] -> CType -> CExpr -> GWMonad (CExpr, [CPred]) +genFrom :: [PProp] -> CType -> CExpr -> GWMonad CExpr genFrom pps ty var = do --traceM ("genFrom type: " ++ (pfpAll ty)) @@ -1176,27 +1141,19 @@ genFrom pps ty var = ifcPrags <- getInterfacePrags ti let prefixes = noPrefixes { ifcp_pragmas = ifcPrags } fieldBlobs <- mapM (meth prefixes ti) fts - let expr = blobsToIfc ti fts fieldBlobs - let bits_types = unions (map fifth fieldBlobs) - ctxs = [ CPred (CTypeclass idBits) [t, cTVarNum v] - | (t, v) <- zip bits_types tmpTyVarIds ] - return (expr, ctxs) + return $ blobsToIfc ti fts fieldBlobs where blobsToIfc ti fts fieldBlobs = - let meths = [ CLValue (setInternal f) [CClause (map CPVar vs) [] e] gs - | (f, vs, e, gs, _) <- fieldBlobs ] + let meths = [ CLValue (setInternal f) [CClause [] [] e] gs + | (f, e, gs) <- fieldBlobs ] in Cinterface (getPosition fts) (Just ti) meths - fifth (_, _, _, _, x) = x - - -- This returns a 5-tuple of a field Id (method or subifc), - -- its argument Ids, its result expression, and its implicit - -- condition (only for methods), and a list of types which need - -- Bits provisos. + -- This returns a 3-tuple of a field Id (method or subifc), + -- its defining expression, and its implicit condition (only for methods). -- Note: The Id is qualified, because it could be something not -- imported by the user (and this not available unqualified). meth :: IfcPrefixes -> Id -> FInf -> - GWMonad (Id, [Id], CExpr, [CQual], [CType]) + GWMonad (Id, CExpr, [CQual]) meth prefixes ifcId (FInf f as r aIds) = do ciPrags <- getInterfaceFieldPrags ifcId f {- f should be qualifed -} @@ -1207,8 +1164,7 @@ genFrom pps ty var = newprefixes <- extendPrefixes prefixes ciPrags r f fieldBlobs <- mapM (meth newprefixes ti) fts let expr = blobsToIfc ti fts fieldBlobs - ctxs = unions (map fifth fieldBlobs) - return (f, [], expr, [], ctxs) + return (f, expr, []) _ -> do isVec <- isVectorInterfaces r case (isVec, as) of @@ -1219,14 +1175,9 @@ genFrom pps ty var = do newprefixes <- extendPrefixes prefixes ciPrags r f meth newprefixes idVector (FInf (mkNumId num) [] tVec []) fieldBlobs <- mapM recurse nums - let (es, gs) = unzip [(e, g) | (_, _, e, g, _) <- fieldBlobs] + let (es, gs) = unzip [(e, g) | (_, e, g) <- fieldBlobs] let vec = cToVector isListN es - let ctxs = case fieldBlobs of - -- each element will have the same ctxs - -- so just take from the first one - (blob:_) -> fifth blob - _ -> [] - return (f, [], vec, concat gs, ctxs) + return (f, vec, concat gs) _ -> do isPA <- isPrimAction r isClock <- isClockType r @@ -1240,26 +1191,10 @@ genFrom pps ty var = let hasNoRdy = isAlwaysRdy pps wbinf || isAlwaysReadyIfc (ifcp_pragmas prefixes ++ ciPrags) let meth_guard = CApply eUnpack [sel wbinf] - let vs = take (length as) (aIds ++ tmpVarXIds) let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let ec = cApply 13 (sel binf) - (map (\ v -> CApply ePack [CVar v]) vs) - (e, res_ctxs) <- - case isInout of - Just iot -> return (CApply ePrimInoutUncast0 [ec], [iot]) - _ -> if (isPA || isClock || isReset) - then return (ec, []) - else - if isAV - then do - retType <- getAVType "genFrom" r - return - (cApply 12 (CVar idFromActionValue_) [ec], - [retType]) - else return (CApply eUnpack [ec], [r]) - let ctxs = nub (res_ctxs ++ as) - return (f, vs, e, qs, ctxs) + let e = CApply (CVar id_fromWrapMethod) [sel binf] + return (f, e, qs) -- -------------------- @@ -1377,7 +1312,8 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = ftps <- mapM collectIfcInfo (reverse cfields) -- get back the arg port to type mapping, for recording flgs <- getFlags - arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps + -- arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps + let arg_pts = [] let arg_infos = thd $ unzip3 vtis (vs, ts) = unzip $ concatMap extractVTPairs arg_infos diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 192621e27..9928a12e6 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -231,6 +231,11 @@ idPolyWrapField = mk_no fsPolyWrapField idLiftModule :: Id idLiftModule = prelude_id_no fsLiftModule +idWrapMethod, id_fromWrapMethod, id_toWrapMethod :: Id +idWrapMethod = prelude_id_no fsWrapMethod +id_fromWrapMethod = prelude_id_no fsFromWrapMethod +id_toWrapMethod = prelude_id_no fsToWrapMethod + -- Used by desugaring id_lam, id_if, id_read, id_write :: Position -> Id id_lam pos = mkId pos fs_lam diff --git a/src/comp/PreStrings.hs b/src/comp/PreStrings.hs index cc06010b6..c26c8843a 100644 --- a/src/comp/PreStrings.hs +++ b/src/comp/PreStrings.hs @@ -342,6 +342,9 @@ fsMetaConsNamed = mkFString "MetaConsNamed" fsMetaConsAnon = mkFString "MetaConsAnon" fsMetaField = mkFString "MetaField" fsPolyWrapField = mkFString "val" +fsWrapMethod = mkFString "WrapMethod" +fsFromWrapMethod = mkFString "fromWrapMethod" +fsToWrapMethod = mkFString "toWrapMethod" -- XXX low ASCII only, please... sAcute = "__" From 363cc7bcdadfd6c51105f0fb0aae91a6d549061f Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Wed, 7 Aug 2024 17:19:25 -0700 Subject: [PATCH 02/43] Attempt at attachting port names with a primative on every input. Doesn't work b/c lambda bodies aren't partially evaluated before iExpandMethod. --- src/Libraries/Base1/Prelude.bs | 37 +++++++++++++++++----------------- src/comp/CSyntaxUtil.hs | 4 ++++ src/comp/GenWrap.hs | 7 +++++-- src/comp/IExpand.hs | 30 ++++++++++++++++++--------- src/comp/IfcBetterInfo.hs | 19 +---------------- src/comp/Prim.hs | 3 +++ 6 files changed, 51 insertions(+), 49 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 6dffeeabc..74edb7884 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -256,7 +256,8 @@ package Prelude( MetaConsNamed(..), MetaConsAnon(..), MetaField(..), Curry(..), AppendTuple(..), AppendTuple'(..), - WrapPorts(..), WrapMethod(..) + WrapPorts(..), WrapMethod(..), + primPortName ) where infixr 0 $ @@ -4416,20 +4417,17 @@ instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where appendTuple' (x, y) z = (x, appendTuple' y z) -data (WrapPort :: $ -> # -> *) name n = WrapPort (Bit n) +primitive primPortName :: String -> Bit n -> Bit n class WrapPorts a p | a -> p where - toPorts :: a -> p + -- Takes a port name and a value to wrap, returns a (tuple of) bits + -- cooresponding to port(s), each tagged with primPortName. + toPorts :: String -> a -> p + -- Takes a (tuple of) bits cooresponding to ports, returns the unwrapped value. fromPorts :: p -> a -{- -instance (Bits a n) => WrapPorts a (WrapPort "foo" n) where - toPorts = WrapPort ∘ pack - fromPorts (WrapPort x) = unpack x --} - instance (Bits a n) => WrapPorts a (Bit n) where - toPorts = pack + toPorts name = primPortName name ∘ pack fromPorts = unpack {- @@ -4444,39 +4442,40 @@ instance (Add n1 1 n, WrapPorts a p1, WrapPorts (Vector n1 a) p2, AppendTuple p1 -- TODO: If there is only one instance for WrapPorts, the first WrapMethod instance below fails to typecheck. instance WrapPorts () () where - toPorts = id + toPorts _ = id fromPorts = id class WrapMethod m w | m -> w where toWrapMethod :: m -> w - fromWrapMethod :: w -> m + fromWrapMethod :: List String -> w -> m instance (WrapPorts a p, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ fromPorts - fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts + fromWrapMethod (Cons h t) f = fromWrapMethod t ∘ uncurryN f ∘ toPorts h + fromWrapMethod Nil _ = error "toWrapMethod: empty arg names list" instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where toWrapMethod = toActionValue_ - fromWrapMethod = fromActionValue_ + fromWrapMethod _ = fromActionValue_ instance (Bits a n) => WrapMethod a (Bit n) where toWrapMethod = pack - fromWrapMethod = unpack + fromWrapMethod _ = unpack -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, -- but this case was being handled in GenWrap. instance WrapMethod PrimAction PrimAction where toWrapMethod = id - fromWrapMethod = id + fromWrapMethod _ = id instance WrapMethod Clock Clock where toWrapMethod = id - fromWrapMethod = id + fromWrapMethod _ = id instance WrapMethod Reset Reset where toWrapMethod = id - fromWrapMethod = id + fromWrapMethod _ = id instance (Bits a n) => WrapMethod (Inout a) (Inout_ n) where toWrapMethod = primInoutCast0 - fromWrapMethod = primInoutUncast0 + fromWrapMethod _ = primInoutUncast0 diff --git a/src/comp/CSyntaxUtil.hs b/src/comp/CSyntaxUtil.hs index 8abbf355f..284339e6d 100644 --- a/src/comp/CSyntaxUtil.hs +++ b/src/comp/CSyntaxUtil.hs @@ -63,6 +63,10 @@ mkMaybe :: (Maybe CExpr) -> CExpr mkMaybe Nothing = CCon idInvalid [] mkMaybe (Just e) = CCon idValid [e] +mkList :: [CExpr] -> CExpr +mkList [] = CCon (idNil noPosition) [] +mkList (e:es) = CCon (idCons $ getPosition e) [e, mkList es] + num_to_cliteral_at :: Integral n => Position -> n -> CLiteral num_to_cliteral_at pos num = CLiteral pos $ LInt $ ilDec (toInteger num) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 0c7278acd..747098780 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -9,7 +9,7 @@ module GenWrap( import Prelude hiding ((<>)) #endif -import Data.List(nub, (\\), find) +import Data.List(nub, (\\), find, genericLength) import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, gets, get, put) @@ -1193,7 +1193,10 @@ genFrom pps ty var = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let e = CApply (CVar id_fromWrapMethod) [sel binf] + let arg_names = mkList + [stringLiteralAt (getPosition i) (getIdString i) + | i <- aIds ++ map mkNumId [genericLength aIds + 1..genericLength as]] + let e = CApply (CVar id_fromWrapMethod) [arg_names, sel binf] return (f, e, qs) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 4943376dd..090493378 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -21,7 +21,7 @@ import Data.List import Data.Maybe import Data.Foldable(foldrM) import Numeric(showIntAtBase) -import Data.Char(intToDigit, ord, chr) +import Data.Char(intToDigit, ord, chr, isDigit) import Control.Monad(when, foldM, zipWithM, mapAndUnzipM) import Control.Monad.Fix(mfix) --import Control.Monad.Fix @@ -1058,15 +1058,19 @@ iExpandMethodLam :: Id -> Integer -> [Id] -> HPred -> Id -> IType -> Pred HeapData -> G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) -iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p = do - -- substitute argument with a modvar and replace with body - let i_n :: Id - i_n = mkIdPost (BetterInfo.mi_prefix bi) (concatFString [fsUnderscore, mkNumFString n]) +iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p = + case eb of + IAps (ICon _ (ICPrim _ PrimPortName)) _ [ename, ebody] -> do + (name, _) <- evalString ename + let pfx :: Id + pfx = BetterInfo.mi_prefix bi i' :: Id - i' = if null (BetterInfo.mi_args bi) then i_n else (BetterInfo.mi_args bi) !! fromInteger (n-1) + i' = if isEmptyId pfx && not (isDigit $ head name) + then mkIdPost pfx $ mkFString name + else mkIdPost pfx (concatFString [fsUnderscore, mkFString name]) + -- substitute argument with a modvar and replace with body eb' :: HExpr - eb' = eSubst li (ICon i' (ICMethArg ty)) eb - -- bi' = if null bi then [] else tail bi + eb' = eSubst li (ICon i' (ICMethArg ty)) ebody let m_orig_type :: Maybe IType m_orig_type = fmap ((flip (!!) (fromInteger (n-1))) . fst . itGetArrows) (BetterInfo.mi_orig_type bi) @@ -1077,9 +1081,11 @@ iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p = do inps = vf_inputs wf1 let wf1' :: VFieldInfo wf1' = case wf1 of - (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } - _ -> internalError "iExpandMethodLam: unexpected wf1" + (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } + _ -> internalError "iExpandMethodLam: unexpected wf1" return ((i', ty) : its, (d, ws1, wf1'), (wd, ws2, wf2)) + -- XXX should be a user error, since someone can write their own WrapPorts instance + _ -> internalError $ "iExpandMethodLam: expected PrimPortName, got " ++ ppReadable eb iExpandMethod' :: HPred -> HClock -> (Id, BetterInfo.BetterInfo, HExpr) -> Pred HeapData -> @@ -2531,6 +2537,10 @@ walkNF e = _ <- internalError ("PrimWhenPred" ++ ppReadable e) (P p' e', ws) <- walkNF e upd (pConjs [p0, p, p']) e' ws + + IAps f@(ICon i (ICPrim _ PrimPortName)) _ [n, e] -> do + (P p e', ws) <- walkNF e + upd (pConj p0 p) (IAps f [] [n, e']) ws -- Any other application is not in NF (which is unexpected?) IAps f ts es -> do diff --git a/src/comp/IfcBetterInfo.hs b/src/comp/IfcBetterInfo.hs index d7a37c96a..555d7840d 100644 --- a/src/comp/IfcBetterInfo.hs +++ b/src/comp/IfcBetterInfo.hs @@ -32,7 +32,6 @@ data BetterInfo = BetterMethodInfo mi_ready :: VPort, -- for ready signal mi_enable :: VPort, -- for enable signal mi_prefix :: Id, -- default prefix for arguments (which are not found in classic) - mi_args :: [Id], -- for arguments mi_orig_type :: Maybe IType -- original (unwrapped) field type } -- XXX Note that the following are unused @@ -58,7 +57,6 @@ noMethodInfo fieldId = BetterMethodInfo {mi_id = fieldId, mi_ready = id_to_vPort $ mkRdyId fieldId, mi_enable = id_to_vPort $ mkEnableId fieldId, mi_prefix = fieldId, - mi_args = [], mi_orig_type = Nothing } @@ -69,7 +67,6 @@ instance PPrint BetterInfo where printMaybe d i "Ready:" (mi_ready info) <> printMaybe d i "Enable:" (mi_enable info) <> text "Prefix:" <> pPrint d i (mi_prefix info) <> - text "Args:" <> pPrint d i (mi_args info) <> printMaybe d i "Original type:" (mi_orig_type info) ) @@ -106,21 +103,7 @@ fieldInfoToBetterInfo flags symTab (fieldId, Just fi) = mi_ready = maybe (id_to_vPort $ mkRdyId fieldId) str_to_vPort mrdy, mi_enable = maybe (id_to_vPort $ mkEnableId fieldId) str_to_vPort men, mi_prefix = maybe fieldId (setIdBaseString fieldId) mprefix, - mi_args = args, mi_orig_type = fmap (iConvT flags symTab) (fi_orig_type fi) } where prags = fi_pragmas fi - (mprefix,mres,mrdy,men,rawargs,_,_) = getMethodPragmaInfo prags - args = genArgNames mprefix fieldId rawargs - - --- Create a list of Ids for method argument names --- Used by IExpand thru IfcbetterNames maybe move it here --- Note that this only uses IPrefixStr and iArgNames, which must be --- kept on the FieldInfo in the SymTab -genArgNames :: Maybe String -> Id -> [Id] -> [Id] -genArgNames mprefix fieldId ids = map (addPrefix mprefix fieldId) ids - where addPrefix :: Maybe String -> Id -> Id -> Id - addPrefix Nothing fid aid = mkUSId fid aid - addPrefix (Just "") _ aid = aid - addPrefix (Just pstr) _ aid = mkIdPre (mkFString $ pstr ++ "_" ) aid + (mprefix,mres,mrdy,men,_,_,_) = getMethodPragmaInfo prags diff --git a/src/comp/Prim.hs b/src/comp/Prim.hs index c1b48345a..64f1444c1 100644 --- a/src/comp/Prim.hs +++ b/src/comp/Prim.hs @@ -64,6 +64,8 @@ data PrimOp = | PrimInoutCast | PrimInoutUncast + | PrimPortName + | PrimIf | PrimMux | PrimPriMux @@ -354,6 +356,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primBOr" = PrimBOr tp "primInoutCast" = PrimInoutCast tp "primInoutUncast" = PrimInoutUncast + tp "primPortName" = PrimPortName tp "primIntegerToBit" = PrimIntegerToBit tp "primIntegerToUIntBits" = PrimIntegerToUIntBits tp "primIntegerToIntBits" = PrimIntegerToIntBits From b24ca9c3948f4d4ad2fb5af85273c4278b69afd5 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 9 Aug 2024 17:28:46 -0700 Subject: [PATCH 03/43] Pass the input port names by tagging methods with a new primative --- src/Libraries/Base1/Prelude.bs | 86 ++++++++++++++++++++---------- src/comp/Error.hs | 4 ++ src/comp/GenBin.hs | 2 + src/comp/GenWrap.hs | 10 ++-- src/comp/IExpand.hs | 96 +++++++++++++++++++++------------- src/comp/ISyntax.hs | 7 +++ src/comp/Prim.hs | 4 +- 7 files changed, 138 insertions(+), 71 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 74edb7884..fdfe28512 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -255,9 +255,9 @@ package Prelude( Meta(..), MetaData(..), StarArg(..), NumArg(..), StrArg(..), ConArg(..), MetaConsNamed(..), MetaConsAnon(..), MetaField(..), - Curry(..), AppendTuple(..), AppendTuple'(..), - WrapPorts(..), WrapMethod(..), - primPortName + Curry(..), AppendTuple(..), AppendTuple'(..), TupleSize(..), + WrapPorts(..), WrapMethod(..), toWrapMethod, + primPortNames ) where infixr 0 $ @@ -4416,19 +4416,26 @@ instance AppendTuple' a b (a, b) where instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where appendTuple' (x, y) z = (x, appendTuple' y z) +class TupleSize a n | a -> n where {} +instance TupleSize () 0 where {} +instance TupleSize a 1 where {} +instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {} -primitive primPortName :: String -> Bit n -> Bit n +-- Tag a method with a list of port names. +primitive primPortNames :: List String -> a -> a class WrapPorts a p | a -> p where - -- Takes a port name and a value to wrap, returns a (tuple of) bits - -- cooresponding to port(s), each tagged with primPortName. - toPorts :: String -> a -> p + -- Takes an unwrapped value and returns a (tuple of) bits cooresponding to port(s). + toPorts :: a -> p -- Takes a (tuple of) bits cooresponding to ports, returns the unwrapped value. fromPorts :: p -> a + -- Takes a proxy value and a base name, returns a list of port names for the type. + portNames :: a -> String -> List String instance (Bits a n) => WrapPorts a (Bit n) where - toPorts name = primPortName name ∘ pack + toPorts = pack fromPorts = unpack + portNames _ base = Cons base nil {- instance WrapPorts (Vector 0 a) () where @@ -4442,40 +4449,65 @@ instance (Add n1 1 n, WrapPorts a p1, WrapPorts (Vector n1 a) p2, AppendTuple p1 -- TODO: If there is only one instance for WrapPorts, the first WrapMethod instance below fails to typecheck. instance WrapPorts () () where - toPorts _ = id + toPorts = id fromPorts = id + portNames _ _ = nil + +checkPortNames :: (WrapPorts a p, TupleSize p n) => a -> String -> List String +checkPortNames _ base = + let pn = portNames ((error "proxy value") :: a) base + in + if listLength pn /= valueOf n + then error $ "WrapPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++ + " ports, but " +++ integerToString (listLength pn) +++ " port names were given" + else pn class WrapMethod m w | m -> w where - toWrapMethod :: m -> w - fromWrapMethod :: List String -> w -> m + toWrapMethod :: List String -> m -> w + + toWrapMethod' :: m -> w + fromWrapMethod :: w -> m + + inputPortNames :: m -> List String -> List String + inputPortNames _ _ = Nil -instance (WrapPorts a p, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where - toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ fromPorts - fromWrapMethod (Cons h t) f = fromWrapMethod t ∘ uncurryN f ∘ toPorts h - fromWrapMethod Nil _ = error "toWrapMethod: empty arg names list" +instance (WrapPorts a p, TupleSize p n, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where + toWrapMethod names = primPortNames (inputPortNames ((error "proxy value") :: (a -> b)) names) ∘ toWrapMethod' + toWrapMethod' f = curryN $ toWrapMethod' ∘ f ∘ fromPorts + fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts + inputPortNames _ (Cons h t) = + checkPortNames ((error "proxy value") :: a) h `listPrimAppend` + inputPortNames ((error "proxy value") :: b) t + inputPortNames _ Nil = error "toWrapMethod: empty arg names list" instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where - toWrapMethod = toActionValue_ - fromWrapMethod _ = fromActionValue_ + toWrapMethod _ = primPortNames Nil ∘ toActionValue_ + toWrapMethod' = toActionValue_ + fromWrapMethod = fromActionValue_ instance (Bits a n) => WrapMethod a (Bit n) where - toWrapMethod = pack - fromWrapMethod _ = unpack + toWrapMethod _ = primPortNames Nil ∘ pack + toWrapMethod' = pack + fromWrapMethod = unpack -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, -- but this case was being handled in GenWrap. instance WrapMethod PrimAction PrimAction where - toWrapMethod = id - fromWrapMethod _ = id + toWrapMethod _ = id + toWrapMethod' = id + fromWrapMethod = id instance WrapMethod Clock Clock where - toWrapMethod = id - fromWrapMethod _ = id + toWrapMethod _ = id + toWrapMethod' = id + fromWrapMethod = id instance WrapMethod Reset Reset where - toWrapMethod = id - fromWrapMethod _ = id + toWrapMethod _ = id + toWrapMethod' = id + fromWrapMethod = id instance (Bits a n) => WrapMethod (Inout a) (Inout_ n) where - toWrapMethod = primInoutCast0 - fromWrapMethod _ = primInoutUncast0 + toWrapMethod _ = primInoutCast0 + toWrapMethod' = primInoutCast0 + fromWrapMethod = primInoutUncast0 diff --git a/src/comp/Error.hs b/src/comp/Error.hs index 6b07910e4..66abc4176 100644 --- a/src/comp/Error.hs +++ b/src/comp/Error.hs @@ -993,6 +993,7 @@ data ErrMsg = | EModuleUndet | EModuleUndetNoMatch | EStringNF String + | EStringListNF String | ENoNF String String | EHasImplicit String | EModPortHasImplicit String String @@ -3928,6 +3929,9 @@ getErrorText (WRuleUndetPred is_meth rule poss) = nest 4 (vcat (map (text . prPosition) poss)) ) +getErrorText (EStringListNF s) = + (Generate 129, empty, s2par ("Not a compile time string list: " ++ s)) + --------------------------------------------------------------------------- --------------------------------------------------------------------------- diff --git a/src/comp/GenBin.hs b/src/comp/GenBin.hs index cad48d9eb..e7dfe642d 100644 --- a/src/comp/GenBin.hs +++ b/src/comp/GenBin.hs @@ -642,6 +642,8 @@ instance Bin (IConInfo a) where internalError "GenBin.Bin(IConInfo).writeBytes: ICPred" writeBytes (ICHandle { }) = internalError "GenBin.Bin(IConInfo).writeBytes: ICHandle" + writeBytes (ICMethod { }) = + internalError "GenBin.Bin(IConInfo).writeBytes: ICMethod" readBytes = do tag <- getI t <- fromBin case tag of diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 747098780..6dee489aa 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1101,8 +1101,11 @@ genTo pps ty mk = return (concat fields) _ -> do -- XXX idEmpty is a horrible way to know no more selection is required + let arg_names = mkList + [stringLiteralAt (getPosition i) (getIdString i) + | i <- aIds ++ map mkNumId [genericLength aIds + 1..genericLength as]] let ec = if f == idEmpty then sel else CSelect sel (setInternal f) - let e = CApply (CVar id_toWrapMethod) [ec] + let e = CApply (CVar id_toWrapMethod) [arg_names, ec] return [CLValue (binId prefixes f) [CClause [] [] e] []] -- -------------------- @@ -1193,10 +1196,7 @@ genFrom pps ty var = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let arg_names = mkList - [stringLiteralAt (getPosition i) (getIdString i) - | i <- aIds ++ map mkNumId [genericLength aIds + 1..genericLength as]] - let e = CApply (CVar id_fromWrapMethod) [arg_names, sel binf] + let e = CApply (CVar id_fromWrapMethod) [sel binf] return (f, e, qs) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 090493378..6e9cb08fd 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1027,8 +1027,12 @@ iExpandField modId implicitCond clkRst (i, bi, e, t) | isRdyId i = iExpandField modId implicitCond clkRst (i, bi, e, t) = do showTopProgress ("Elaborating method " ++ quote (pfpString i)) setIfcSchedNameScopeProgress (Just (IEP_Method i False)) + (_, P p e') <- evalUH e + let (ins, eb) = case e' of + ICon _ (ICMethod _ ins eb) -> (ins, eb) + _ -> internalError ("iExpandField: expected ICMethod: " ++ ppReadable e') (its, ((IDef i1 t1 e1 _), ws1, fi1), ((IDef wi wt we _), ws2, fi2)) - <- iExpandMethod modId 1 [] implicitCond clkRst (i, bi, e) + <- iExpandMethod modId 1 [] implicitCond clkRst (i, bi, ins, eb) let wp1 = wsToProps ws1 -- default clock domain forced in by iExpandField let wp2 = wsToProps ws2 setIfcSchedNameScopeProgress Nothing @@ -1037,10 +1041,10 @@ iExpandField modId implicitCond clkRst (i, bi, e, t) = do -- expand a method iExpandMethod :: Id -> Integer -> [Id] -> HPred -> - (HClock, HReset) -> (Id, BetterInfo.BetterInfo, HExpr) -> + (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [String], HExpr) -> G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) -iExpandMethod modId n args implicitCond clkRst@(curClk, _) (i, bi, e) = do +iExpandMethod modId n args implicitCond clkRst@(curClk, _) (i, bi, ins, e) = do when doDebug $ traceM ("iExpandMethod " ++ ppString i ++ " " ++ ppReadable e) (_, P p e') <- evalUH e case e' of @@ -1050,42 +1054,41 @@ iExpandMethod modId n args implicitCond clkRst@(curClk, _) (i, bi, e) = do -- a GenWrap-added context that wasn't satisfied, and GenWrap -- should only be adding Bits) errG (reportNonSynthTypeInMethod modId i e') - ILam li ty eb -> iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p + ILam li ty eb -> iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, eb) li ty p _ -> iExpandMethod' implicitCond curClk (i, bi, e') p iExpandMethodLam :: Id -> Integer -> [Id] -> HPred -> - (HClock, HReset) -> (Id, BetterInfo.BetterInfo, HExpr) -> + (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [String], HExpr) -> Id -> IType -> Pred HeapData -> G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) -iExpandMethodLam modId n args implicitCond clkRst (i, bi, eb) li ty p = - case eb of - IAps (ICon _ (ICPrim _ PrimPortName)) _ [ename, ebody] -> do - (name, _) <- evalString ename - let pfx :: Id - pfx = BetterInfo.mi_prefix bi - i' :: Id - i' = if isEmptyId pfx && not (isDigit $ head name) - then mkIdPost pfx $ mkFString name - else mkIdPost pfx (concatFString [fsUnderscore, mkFString name]) - -- substitute argument with a modvar and replace with body - eb' :: HExpr - eb' = eSubst li (ICon i' (ICMethArg ty)) ebody - let m_orig_type :: Maybe IType - m_orig_type = fmap ((flip (!!) (fromInteger (n-1))) . fst . itGetArrows) - (BetterInfo.mi_orig_type bi) - maybe (return ()) (saveTopModPortType (id_to_vName i')) m_orig_type - (its, (d, ws1, wf1), (wd, ws2, wf2)) <- - iExpandMethod modId (n+1) (i':args) (pConj implicitCond p) clkRst (i, bi, eb') - let inps :: [VPort] - inps = vf_inputs wf1 - let wf1' :: VFieldInfo - wf1' = case wf1 of - (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } - _ -> internalError "iExpandMethodLam: unexpected wf1" - return ((i', ty) : its, (d, ws1, wf1'), (wd, ws2, wf2)) - -- XXX should be a user error, since someone can write their own WrapPorts instance - _ -> internalError $ "iExpandMethodLam: expected PrimPortName, got " ++ ppReadable eb +iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, eb) li ty p = do + traceM ("iExpandMethodLam " ++ ppString i ++ " " ++ show ins) + let pfx :: Id + pfx = BetterInfo.mi_prefix bi + name :: String + name = head ins + i' :: Id + i' = if isEmptyId pfx && not (isDigit $ head name) + then mkIdPost pfx $ mkFString name + else mkIdPost pfx (concatFString [fsUnderscore, mkFString name]) + -- substitute argument with a modvar and replace with body + eb' :: HExpr + eb' = eSubst li (ICon i' (ICMethArg ty)) eb + -- XXX we aren't indexing this list properly here! + -- let m_orig_type :: Maybe IType + -- m_orig_type = fmap ((flip (!!) (fromInteger (n-1))) . fst . itGetArrows) + -- (BetterInfo.mi_orig_type bi) + --maybe (return ()) (saveTopModPortType (id_to_vName i')) m_orig_type + (its, (d, ws1, wf1), (wd, ws2, wf2)) <- + iExpandMethod modId (n+1) (i':args) (pConj implicitCond p) clkRst (i, bi, tail ins, eb') + let inps :: [VPort] + inps = vf_inputs wf1 + let wf1' :: VFieldInfo + wf1' = case wf1 of + (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } + _ -> internalError "iExpandMethodLam: unexpected wf1" + return ((i', ty) : its, (d, ws1, wf1'), (wd, ws2, wf2)) iExpandMethod' :: HPred -> HClock -> (Id, BetterInfo.BetterInfo, HExpr) -> Pred HeapData -> @@ -2128,6 +2131,24 @@ evalString e = do _ -> do e'' <- unheapAll e' errG (getIExprPosition e'', EStringNF (ppString e'')) +evalStringList :: HExpr -> G ([String], Position) +evalStringList e = do + e' <- evaleUH e + case e' of + IAps (ICon _ c) _ [a] -> do + a' <- evaleUH a + -- XXX this is a horrible way of pulling apart a list, but I don't think there is a better way: + case a' of + IAps (ICon i' (ICTuple {})) _ [e_h, e_t] | getIdBaseString i' == "List_$Cons" -> do + (h, _) <- evalString e_h + (t, _) <- evalStringList e_t + return (h:t, getIExprPosition e') + ICon _ (ICInt _ (IntLit { ilValue = 0 })) -> + return ([], getIExprPosition e') + _ -> internalError ("evalStringList con: " ++ showTypeless a') + _ -> do e'' <- unheapAll e' + errG (getIExprPosition e', EStringListNF (ppString e')) + ----------------------------------------------------------------------------- evalHandle :: HExpr -> G Handle @@ -2537,10 +2558,6 @@ walkNF e = _ <- internalError ("PrimWhenPred" ++ ppReadable e) (P p' e', ws) <- walkNF e upd (pConjs [p0, p, p']) e' ws - - IAps f@(ICon i (ICPrim _ PrimPortName)) _ [n, e] -> do - (P p e', ws) <- walkNF e - upd (pConj p0 p) (IAps f [] [n, e']) ws -- Any other application is not in NF (which is unexpected?) IAps f ts es -> do @@ -3083,6 +3100,11 @@ conAp' i (ICPrim _ PrimIsRawUndefined) _ (T t : E e : as) = do _ -> -- do traceM ("IsRawUndefined: False") return (P p iFalse) +conAp' i (ICPrim _ PrimPortNames) _ [T t, E eInNames, E meth] = do + (inNames, _) <- evalStringList eInNames + P p meth' <- eval1 meth + return $ P p $ ICon (dummyId noPosition) $ ICMethod {iConType = t, iInputNames = inNames, iMethod = meth'} + -- XXX is this still needed? conAp' i (ICUndet { iConType = t }) e as | t == itClock = errG (getIdPosition i, EUndeterminedClock) diff --git a/src/comp/ISyntax.hs b/src/comp/ISyntax.hs index c8af1ea6b..4ac51b3cf 100644 --- a/src/comp/ISyntax.hs +++ b/src/comp/ISyntax.hs @@ -842,6 +842,8 @@ data IConInfo a = -- as an argument to PrimAddSchedPragmas (applied to rules). -- only exists before expansion | ICSchedPragmas { iConType :: IType, iPragmas :: [CSchedulePragma] } + + | ICMethod { iConType :: IType, iInputNames :: [String], iMethod :: IExpr a } | ICClock { iConType :: IType, iClock :: IClock a } | ICReset { iConType :: IType, iReset :: IReset a } -- iReset has effective type itBit1 | ICInout { iConType :: IType, iInout :: IInout a } @@ -891,6 +893,7 @@ ordC (ICAttrib { }) = 28 ordC (ICPosition { }) = 29 ordC (ICType { }) = 30 ordC (ICPred { }) = 31 +ordC (ICMethod { }) = 32 instance Eq (IConInfo a) where x == y = cmpC x y == EQ @@ -935,6 +938,8 @@ cmpC c1 c2 = ICIFace { ifcTyId = ti1, ifcIds = is1 } -> compare (ti1, is1) (ifcTyId c2, ifcIds c2) ICRuleAssert { iAsserts = asserts } -> compare asserts (iAsserts c2) ICSchedPragmas { iPragmas = pragmas } -> compare pragmas (iPragmas c2) + ICMethod { iInputNames = inames1, iMethod = meth1 } -> + compare (inames1, meth1) (iInputNames c2, iMethod c2) -- the ICon Id is not sufficient for equality comparison for Clk/Rst ICClock { iClock = clock1 } -> compare clock1 (iClock c2) ICReset { iReset = reset1 } -> compare reset1 (iReset c2) @@ -1325,6 +1330,7 @@ instance Hyper (IConInfo a) where hyper (ICIFace x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICRuleAssert x1 x2) y = hyper2 x1 x2 y hyper (ICSchedPragmas x1 x2) y = hyper2 x1 x2 y + hyper (ICMethod x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICClock x1 x2) y = hyper2 x1 x2 y hyper (ICReset x1 x2) y = hyper2 x1 x2 y hyper (ICInout x1 x2) y = hyper2 x1 x2 y @@ -1546,6 +1552,7 @@ showTypelessCI (ICValue {iConType = t, iValDef = e}) = "(ICValue)" showTypelessCI (ICIFace {iConType = t, ifcTyId = i, ifcIds = ids}) = "(ICIFace _ " ++ (show i) ++ " " ++ (show ids) ++ ")" showTypelessCI (ICRuleAssert {iConType = t, iAsserts = rps}) = "(ICRuleAssert _ " ++ (show rps) ++ ")" showTypelessCI (ICSchedPragmas {iConType = t, iPragmas = sps}) = "(ICSchedPragmas _ " ++ (show sps) ++ ")" +showTypelessCI (ICMethod {iConType = t, iInputNames = ins, iMethod = m }) = "(ICMethod " ++ (show ins) ++ " " ++ (ppReadable m) ++ ")" showTypelessCI (ICClock {iConType = t, iClock = clock}) = "(ICClock)" showTypelessCI (ICReset {iConType = t, iReset = reset}) = "(ICReset)" showTypelessCI (ICInout {iConType = t, iInout = inout}) = "(ICInout)" diff --git a/src/comp/Prim.hs b/src/comp/Prim.hs index 64f1444c1..3708dce00 100644 --- a/src/comp/Prim.hs +++ b/src/comp/Prim.hs @@ -64,7 +64,7 @@ data PrimOp = | PrimInoutCast | PrimInoutUncast - | PrimPortName + | PrimPortNames | PrimIf | PrimMux @@ -356,7 +356,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primBOr" = PrimBOr tp "primInoutCast" = PrimInoutCast tp "primInoutUncast" = PrimInoutUncast - tp "primPortName" = PrimPortName + tp "primPortNames" = PrimPortNames tp "primIntegerToBit" = PrimIntegerToBit tp "primIntegerToUIntBits" = PrimIntegerToUIntBits tp "primIntegerToIntBits" = PrimIntegerToIntBits From 92fa2e8bceb430464ae683ee132148e915091aa1 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 9 Aug 2024 17:50:36 -0700 Subject: [PATCH 04/43] Refactor WrapMethod type class --- src/Libraries/Base1/Prelude.bs | 113 +++++++++++++++++---------------- src/comp/GenWrap.hs | 6 +- src/comp/IExpand.hs | 2 +- src/comp/PreIds.hs | 8 +-- src/comp/PreStrings.hs | 6 +- src/comp/Prim.hs | 4 +- 6 files changed, 72 insertions(+), 67 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index fdfe28512..cf704460b 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -256,8 +256,8 @@ package Prelude( MetaConsNamed(..), MetaConsAnon(..), MetaField(..), Curry(..), AppendTuple(..), AppendTuple'(..), TupleSize(..), - WrapPorts(..), WrapMethod(..), toWrapMethod, - primPortNames + WrapPorts(..), WrapMethod(..), WrapField(..), + primMethod ) where infixr 0 $ @@ -4421,8 +4421,63 @@ instance TupleSize () 0 where {} instance TupleSize a 1 where {} instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {} --- Tag a method with a list of port names. -primitive primPortNames :: List String -> a -> a +-- Tag a method with metadata. +-- Currently just the list of input port names. +primitive primMethod :: List String -> a -> a + +class WrapField f w | f -> w where + -- Takes a list of argument names, converts a synthesized interface field value to + -- its wrapper interface field. + toWrapField :: List String -> f -> w + -- Converts a wrapper interface field value to its synthesized interface field. + fromWrapField :: w -> f + +instance (WrapMethod m w) => (WrapField m w) where + toWrapField names = primMethod (inputPortNames ((error "proxy value") :: m) names) ∘ toWrapMethod + fromWrapField = fromWrapMethod + +-- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, +-- but this case was being handled in GenWrap. +instance WrapField PrimAction PrimAction where + toWrapField _ = id + fromWrapField = id + +instance WrapField Clock Clock where + toWrapField _ = id + fromWrapField = id + +instance WrapField Reset Reset where + toWrapField _ = id + fromWrapField = id + +instance (Bits a n) => WrapField (Inout a) (Inout_ n) where + toWrapField _ = primInoutCast0 + fromWrapField = primInoutUncast0 + +class WrapMethod m w | m -> w where + -- Convert a synthesized interface method to its wrapper interface method. + toWrapMethod :: m -> w + -- Convert a wrapper interface method to its synthesized interface method. + fromWrapMethod :: w -> m + -- Comput the list of input port names for a method. + inputPortNames :: m -> List String -> List String + inputPortNames _ _ = Nil + +instance (WrapPorts a p, TupleSize p n, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where + toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ fromPorts + fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts + inputPortNames _ (Cons h t) = + checkPortNames ((error "proxy value") :: a) h `listPrimAppend` + inputPortNames ((error "proxy value") :: b) t + inputPortNames _ Nil = error "toWrapMethod: empty arg names list" + +instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where + toWrapMethod = toActionValue_ + fromWrapMethod = fromActionValue_ + +instance (Bits a n) => WrapMethod a (Bit n) where + toWrapMethod = pack + fromWrapMethod = unpack class WrapPorts a p | a -> p where -- Takes an unwrapped value and returns a (tuple of) bits cooresponding to port(s). @@ -4461,53 +4516,3 @@ checkPortNames _ base = then error $ "WrapPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++ " ports, but " +++ integerToString (listLength pn) +++ " port names were given" else pn - -class WrapMethod m w | m -> w where - toWrapMethod :: List String -> m -> w - - toWrapMethod' :: m -> w - fromWrapMethod :: w -> m - - inputPortNames :: m -> List String -> List String - inputPortNames _ _ = Nil - -instance (WrapPorts a p, TupleSize p n, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where - toWrapMethod names = primPortNames (inputPortNames ((error "proxy value") :: (a -> b)) names) ∘ toWrapMethod' - toWrapMethod' f = curryN $ toWrapMethod' ∘ f ∘ fromPorts - fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts - inputPortNames _ (Cons h t) = - checkPortNames ((error "proxy value") :: a) h `listPrimAppend` - inputPortNames ((error "proxy value") :: b) t - inputPortNames _ Nil = error "toWrapMethod: empty arg names list" - -instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where - toWrapMethod _ = primPortNames Nil ∘ toActionValue_ - toWrapMethod' = toActionValue_ - fromWrapMethod = fromActionValue_ - -instance (Bits a n) => WrapMethod a (Bit n) where - toWrapMethod _ = primPortNames Nil ∘ pack - toWrapMethod' = pack - fromWrapMethod = unpack - --- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, --- but this case was being handled in GenWrap. -instance WrapMethod PrimAction PrimAction where - toWrapMethod _ = id - toWrapMethod' = id - fromWrapMethod = id - -instance WrapMethod Clock Clock where - toWrapMethod _ = id - toWrapMethod' = id - fromWrapMethod = id - -instance WrapMethod Reset Reset where - toWrapMethod _ = id - toWrapMethod' = id - fromWrapMethod = id - -instance (Bits a n) => WrapMethod (Inout a) (Inout_ n) where - toWrapMethod _ = primInoutCast0 - toWrapMethod' = primInoutCast0 - fromWrapMethod = primInoutUncast0 diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 6dee489aa..4089ce969 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -901,7 +901,7 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = return (concat fields, concat props) _ -> do -- ELSE NOT a Vec let v = cTVar $ head tmpTyVarIds - let ctx = CPred (CTypeclass idWrapMethod) [foldr arrow rettype argtypes, v] + let ctx = CPred (CTypeclass idWrapField) [foldr arrow rettype argtypes, v] let fi = binId prefixes fieldId -- @@ -1105,7 +1105,7 @@ genTo pps ty mk = [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds ++ map mkNumId [genericLength aIds + 1..genericLength as]] let ec = if f == idEmpty then sel else CSelect sel (setInternal f) - let e = CApply (CVar id_toWrapMethod) [arg_names, ec] + let e = CApply (CVar id_toWrapField) [arg_names, ec] return [CLValue (binId prefixes f) [CClause [] [] e] []] -- -------------------- @@ -1196,7 +1196,7 @@ genFrom pps ty var = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let e = CApply (CVar id_fromWrapMethod) [sel binf] + let e = CApply (CVar id_fromWrapField) [sel binf] return (f, e, qs) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 6e9cb08fd..8979ca9c9 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -3100,7 +3100,7 @@ conAp' i (ICPrim _ PrimIsRawUndefined) _ (T t : E e : as) = do _ -> -- do traceM ("IsRawUndefined: False") return (P p iFalse) -conAp' i (ICPrim _ PrimPortNames) _ [T t, E eInNames, E meth] = do +conAp' i (ICPrim _ PrimMethod) _ [T t, E eInNames, E meth] = do (inNames, _) <- evalStringList eInNames P p meth' <- eval1 meth return $ P p $ ICon (dummyId noPosition) $ ICMethod {iConType = t, iInputNames = inNames, iMethod = meth'} diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 9928a12e6..980bfda04 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -231,10 +231,10 @@ idPolyWrapField = mk_no fsPolyWrapField idLiftModule :: Id idLiftModule = prelude_id_no fsLiftModule -idWrapMethod, id_fromWrapMethod, id_toWrapMethod :: Id -idWrapMethod = prelude_id_no fsWrapMethod -id_fromWrapMethod = prelude_id_no fsFromWrapMethod -id_toWrapMethod = prelude_id_no fsToWrapMethod +idWrapField, id_fromWrapField, id_toWrapField :: Id +idWrapField = prelude_id_no fsWrapField +id_fromWrapField = prelude_id_no fsFromWrapField +id_toWrapField = prelude_id_no fsToWrapField -- Used by desugaring id_lam, id_if, id_read, id_write :: Position -> Id diff --git a/src/comp/PreStrings.hs b/src/comp/PreStrings.hs index c26c8843a..0fb91ca30 100644 --- a/src/comp/PreStrings.hs +++ b/src/comp/PreStrings.hs @@ -342,9 +342,9 @@ fsMetaConsNamed = mkFString "MetaConsNamed" fsMetaConsAnon = mkFString "MetaConsAnon" fsMetaField = mkFString "MetaField" fsPolyWrapField = mkFString "val" -fsWrapMethod = mkFString "WrapMethod" -fsFromWrapMethod = mkFString "fromWrapMethod" -fsToWrapMethod = mkFString "toWrapMethod" +fsWrapField = mkFString "WrapField" +fsFromWrapField = mkFString "fromWrapField" +fsToWrapField = mkFString "toWrapField" -- XXX low ASCII only, please... sAcute = "__" diff --git a/src/comp/Prim.hs b/src/comp/Prim.hs index 3708dce00..c1dc90e86 100644 --- a/src/comp/Prim.hs +++ b/src/comp/Prim.hs @@ -64,7 +64,7 @@ data PrimOp = | PrimInoutCast | PrimInoutUncast - | PrimPortNames + | PrimMethod | PrimIf | PrimMux @@ -356,7 +356,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primBOr" = PrimBOr tp "primInoutCast" = PrimInoutCast tp "primInoutUncast" = PrimInoutUncast - tp "primPortNames" = PrimPortNames + tp "primMethod" = PrimMethod tp "primIntegerToBit" = PrimIntegerToBit tp "primIntegerToUIntBits" = PrimIntegerToUIntBits tp "primIntegerToIntBits" = PrimIntegerToIntBits From c6b22fa47ce8785a961f67dd6cbaba800a977451 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 12 Aug 2024 19:47:53 -0700 Subject: [PATCH 05/43] Input port splitting works end-to-end, modulo sanity checks and saving port types --- src/Libraries/Base1/Prelude.bs | 131 ++++++++++++++++++++++++--------- src/comp/GenWrap.hs | 37 +++------- src/comp/IExpand.hs | 24 ++---- src/comp/IExpandUtils.hs | 5 +- src/comp/IfcBetterInfo.hs | 12 +-- 5 files changed, 116 insertions(+), 93 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index cf704460b..51108ff1f 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -256,7 +256,7 @@ package Prelude( MetaConsNamed(..), MetaConsAnon(..), MetaField(..), Curry(..), AppendTuple(..), AppendTuple'(..), TupleSize(..), - WrapPorts(..), WrapMethod(..), WrapField(..), + WrapField(..), WrapMethod(..), WrapPorts(..), SplitPorts(..), primMethod ) where @@ -4429,12 +4429,18 @@ class WrapField f w | f -> w where -- Takes a list of argument names, converts a synthesized interface field value to -- its wrapper interface field. toWrapField :: List String -> f -> w + -- Converts a wrapper interface field value to its synthesized interface field. fromWrapField :: w -> f + -- Save the port types for a field in the wrapped interface. + saveFieldPortTypes :: f -> Maybe Name__ -> List String -> String -> Module () + saveFieldPortTypes _ _ _ _ = return () + instance (WrapMethod m w) => (WrapField m w) where - toWrapField names = primMethod (inputPortNames ((error "proxy value") :: m) names) ∘ toWrapMethod + toWrapField names = primMethod (inputPortNames (_:: m) names) ∘ toWrapMethod fromWrapField = fromWrapMethod + saveFieldPortTypes = saveMethodPortTypes -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, -- but this case was being handled in GenWrap. @@ -4453,44 +4459,114 @@ instance WrapField Reset Reset where instance (Bits a n) => WrapField (Inout a) (Inout_ n) where toWrapField _ = primInoutCast0 fromWrapField = primInoutUncast0 + saveFieldPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) class WrapMethod m w | m -> w where -- Convert a synthesized interface method to its wrapper interface method. toWrapMethod :: m -> w + -- Convert a wrapper interface method to its synthesized interface method. fromWrapMethod :: w -> m - -- Comput the list of input port names for a method. + + -- Compute the list of input port names for a method, from its argument names. inputPortNames :: m -> List String -> List String inputPortNames _ _ = Nil -instance (WrapPorts a p, TupleSize p n, WrapMethod b v, Curry (p -> v) w) => WrapMethod (a -> b) w where - toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ fromPorts - fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ toPorts + -- Save the port types for a method. + saveMethodPortTypes :: m -> Maybe Name__ -> List String -> String -> Module () + +instance (SplitPorts a p, TupleSize p n, WrapPorts p pb, WrapMethod b v, Curry (pb -> v) w) => + WrapMethod (a -> b) w where + toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ unsplitPorts ∘ unpackPorts + fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ packPorts ∘ splitPorts inputPortNames _ (Cons h t) = - checkPortNames ((error "proxy value") :: a) h `listPrimAppend` - inputPortNames ((error "proxy value") :: b) t - inputPortNames _ Nil = error "toWrapMethod: empty arg names list" + checkPortNames (_ :: a) h `listPrimAppend` + inputPortNames (_ :: b) t + inputPortNames _ Nil = error "inputPortNames: empty arg names list" + saveMethodPortTypes _ name (Cons h t) result = do + savePortTypes (_ :: p) name $ checkPortNames (_ :: a) h + saveMethodPortTypes (_ :: b) name t result + saveMethodPortTypes _ _ Nil _ = error "saveMethodPortTypes: empty arg names list" instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where toWrapMethod = toActionValue_ fromWrapMethod = fromActionValue_ + saveMethodPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) instance (Bits a n) => WrapMethod a (Bit n) where toWrapMethod = pack fromWrapMethod = unpack + saveMethodPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) -class WrapPorts a p | a -> p where - -- Takes an unwrapped value and returns a (tuple of) bits cooresponding to port(s). - toPorts :: a -> p - -- Takes a (tuple of) bits cooresponding to ports, returns the unwrapped value. - fromPorts :: p -> a - -- Takes a proxy value and a base name, returns a list of port names for the type. - portNames :: a -> String -> List String +{- +Eventually, we should support splitting multiple output ports. +instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod (ActionValue a) (ActionValue pb) where + toWrapMethod = fmap packPorts + fromWrapMethod = fmap unpackPorts + outputPortNames _ base = checkPortNames (_ :: a) base + saveMethodPortTypes _ name _ result = + savePortTypes (_ :: p) name $ checkPortNames (_ :: a) result + +instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod a pb where + toWrapMethod a = packPorts a + fromWrapMethod a = unpackPorts a + outputPortNames _ base = checkPortNames (_ :: a) base + saveMethodPortTypes _ name _ result = + savePortTypes (_ :: p) name $ checkPortNames (_ :: a) result +-} + +class WrapPorts p pb | p -> pb where + -- Convert from a tuple of values to a tuple of bits. + packPorts :: p -> pb + -- Convert from a tuple of bits to a tuple of values. + unpackPorts :: pb -> p + -- Save the port types, given their names. + savePortTypes :: p -> Maybe Name__ -> List String -> Module () + +instance (Bits a n, WrapPorts b bb) => WrapPorts (a, b) (Bit n, bb) where + packPorts (a, b) = (pack a, packPorts b) + unpackPorts (a, b) = (unpack a, unpackPorts b) + savePortTypes _ name (Cons h t) = do + primSavePortType name h $ typeOf (_ :: a) + savePortTypes (_ :: b) name t + savePortTypes _ _ Nil = error "savePortTypes: empty port names list" instance (Bits a n) => WrapPorts a (Bit n) where - toPorts = pack - fromPorts = unpack - portNames _ base = Cons base nil + packPorts = pack + unpackPorts = unpack + savePortTypes _ name (Cons h _) = primSavePortType name h $ typeOf (_ :: a) + savePortTypes _ _ Nil = error "savePortTypes: empty port names list" + +instance WrapPorts () () where + packPorts _ = () + unpackPorts _ = () + savePortTypes _ _ _ = return () + +checkPortNames :: (SplitPorts a p, TupleSize p n) => a -> String -> List String +checkPortNames proxy base = + let pn = portNames proxy base + in + if listLength pn /= valueOf n + then error $ "SplitPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++ + " ports, but " +++ integerToString (listLength pn) +++ " port names were given" + else pn + +class SplitPorts a p | a -> p where + splitPorts :: a -> p + unsplitPorts :: p -> a + portNames :: a -> String -> List String + +-- XXX if the default instance is the only one, then it gets inlined in CtxReduce +-- and other instances for this class are ignored. +instance SplitPorts () () where + splitPorts = id + unsplitPorts = id + portNames _ _ = Nil + +instance SplitPorts a a where + splitPorts = id + unsplitPorts = id + portNames _ base = Cons base Nil {- instance WrapPorts (Vector 0 a) () where @@ -4500,19 +4576,4 @@ instance WrapPorts (Vector 0 a) () where instance (Add n1 1 n, WrapPorts a p1, WrapPorts (Vector n1 a) p2, AppendTuple p1 p2 p) => WrapPorts (Vector n a) p where toPorts v = appendTuple (toPorts $ head v) (toPorts $ tail v) --} - --- TODO: If there is only one instance for WrapPorts, the first WrapMethod instance below fails to typecheck. -instance WrapPorts () () where - toPorts = id - fromPorts = id - portNames _ _ = nil - -checkPortNames :: (WrapPorts a p, TupleSize p n) => a -> String -> List String -checkPortNames _ base = - let pn = portNames ((error "proxy value") :: a) base - in - if listLength pn /= valueOf n - then error $ "WrapPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++ - " ports, but " +++ integerToString (listLength pn) +++ " port names were given" - else pn +-} \ No newline at end of file diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 4089ce969..d2db4dd2a 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1187,7 +1187,6 @@ genFrom pps ty var = isReset <- isResetType r isInout <- isInoutType r let isIot = isInout /= Nothing - isAV <- isActionValue r let binf = binId prefixes f let wbinf = mkRdyId binf let sel = CSelect var @@ -1315,6 +1314,8 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = ftps <- mapM collectIfcInfo (reverse cfields) -- get back the arg port to type mapping, for recording flgs <- getFlags + -- XXX Need to handle module arguments here. + -- XXX Need to sanity check port names after elaboration. -- arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps let arg_pts = [] @@ -1539,7 +1540,9 @@ genFromBody arg_pts vfield_map mk true_ifc_ids si fts = let pos = getIdPosition si let mkMethod = mkFromBind vfield_map true_ifc_ids (CVar (id_t pos)) (meths, ifc_ptss) <- mapAndUnzipM mkMethod fts + -- TODO: Save "port types" for clocks, resets, inouts here. let -- interface save-port-type statements + -- XXX need to use the type class here ifc_sptStmts = map (uncurry (savePortTypeStmt (CVar id_x))) (concat ifc_ptss) -- argument save-port-type statements @@ -1557,6 +1560,8 @@ genFromBody arg_pts vfield_map mk true_ifc_ids si fts = -- Creates a method for the module body -- also returns the raw port-type information for correlation -- XXX some of this can be replaced with a call to "mkFrom_" +-- Currently there is an optimization preventing this - we avoid adding guards for +-- ready signals that are known to be constant True, which isn't known when mkFrom_ is generated. mkFromBind :: M.Map Id VFieldInfo -> [Id] -> CExpr -> FInf -> GWMonad (CDefl, [(VPort, CType)]) mkFromBind vfield_map true_ifc_ids var ft = do @@ -1597,39 +1602,14 @@ mkFromBind vfield_map true_ifc_ids var ft = isReset <- isResetType r isInout <- isInoutType r let isIot = isInout/=Nothing - isAV <- isActionValue r let binf = binId prefixes f let wbinf = mkRdyId binf let sel = CSelect var let meth_guard = CApply eUnpack [sel wbinf] - let vs = take (length as) (aIds ++ tmpVarXIds) let qs = if (wbinf `elem` true_ifc_ids || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let ec = cApply 13 (sel binf) (map (\ v -> CApply ePack [CVar v]) vs) - let e = - case isInout of - Just _ -> (CApply ePrimInoutUncast0 [ec]) - _ -> if (isPA || isClock || isReset) - then ec - else - if isAV - then cApply 12 (CVar idFromActionValue_) [ec] - else CApply eUnpack [ec] - pts <- case (M.lookup binf vfield_map) of - Just (Method { vf_inputs = inps, - vf_output = mo }) -> do - output_type <- if isAV then - getAVType "mkFromBind" r - else return r - return ((maybeToList (fmap (\p -> (p, output_type)) mo)) ++ - zip inps as) - Just (Inout { vf_inout = vn }) -> do - let ty = r - vp = (vn, []) - return [(vp,ty)] - _ -> do --traceM ("no field info: " ++ ppReadable (f, binf, vfield_map)) - return [] - return (f, cLams vs e, qs, pts) + let e = CApply (CVar id_fromWrapField) [sel binf] + return (f, e, qs, []) @@ -2131,6 +2111,7 @@ chkUserPragmas pps ifc = do -- ==================== -- Saving name/type information +-- XXX is liftModule really needed for these? -- liftModule $ primSavePortType (Valid v) s t savePortTypeStmt :: CExpr -> (VName, b) -> CType -> CMStmt diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 8979ca9c9..28bcdea0e 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1015,9 +1015,6 @@ iExpandField modId implicitCond clkRst (i, bi, e, t) | isitInout_ t = do (iinout, e') <- evalInout e let modPos = getPosition modId (ws, fi) <- makeIfcInout modPos i (BetterInfo.mi_prefix bi) iinout - let mType = fmap (snd . itGetArrows) (BetterInfo.mi_orig_type bi) - vname = vf_inout fi - maybe (return ()) (saveTopModPortType vname) mType setIfcSchedNameScopeProgress Nothing return [(IEFace i [] (Just (e',t)) Nothing ws fi)] @@ -1032,7 +1029,7 @@ iExpandField modId implicitCond clkRst (i, bi, e, t) = do ICon _ (ICMethod _ ins eb) -> (ins, eb) _ -> internalError ("iExpandField: expected ICMethod: " ++ ppReadable e') (its, ((IDef i1 t1 e1 _), ws1, fi1), ((IDef wi wt we _), ws2, fi2)) - <- iExpandMethod modId 1 [] implicitCond clkRst (i, bi, ins, eb) + <- iExpandMethod modId 1 [] (pConj implicitCond p) clkRst (i, bi, ins, eb) let wp1 = wsToProps ws1 -- default clock domain forced in by iExpandField let wp2 = wsToProps ws2 setIfcSchedNameScopeProgress Nothing @@ -1075,11 +1072,6 @@ iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, eb) li ty p = do -- substitute argument with a modvar and replace with body eb' :: HExpr eb' = eSubst li (ICon i' (ICMethArg ty)) eb - -- XXX we aren't indexing this list properly here! - -- let m_orig_type :: Maybe IType - -- m_orig_type = fmap ((flip (!!) (fromInteger (n-1))) . fst . itGetArrows) - -- (BetterInfo.mi_orig_type bi) - --maybe (return ()) (saveTopModPortType (id_to_vName i')) m_orig_type (its, (d, ws1, wf1), (wd, ws2, wf2)) <- iExpandMethod modId (n+1) (i':args) (pConj implicitCond p) clkRst (i, bi, tail ins, eb') let inps :: [VPort] @@ -1158,14 +1150,6 @@ iExpandMethod' implicitCond curClk (i, bi, e0) p0 = do let rdyPort :: VPort rdyPort = BetterInfo.mi_ready bi - let mType :: Maybe IType - mType = fmap (snd . itGetArrows) (BetterInfo.mi_orig_type bi) - maybe (return ()) (\t -> do - maybe (return ()) (\(n,_) -> do - if (isActionType methType) then - maybe (return ()) (saveTopModPortType n) (getAVType t) - else saveTopModPortType n t) outputPort) mType - -- split wire sets for more accurate tracking return ([], ((IDef i (iGetType final_e) final_e []), final_ws, @@ -4102,7 +4086,7 @@ getBuriedPreds (IAps a@(ICon _ (ICPrim _ PrimBOr)) b [e1, e2]) = do -- the following are followed because they are strict, -- and we want to unheap the references in their arguments getBuriedPreds (IAps a@(ICon _ p@(ICPrim _ _)) b es) = do - --traceM("getBuriedPreds: prim") + -- traceM("getBuriedPreds: prim") ps <- mapM getBuriedPreds es return (foldr1 pConj ps) getBuriedPreds (IAps a@(ICon _ (ICForeign { })) b es) = do @@ -4123,6 +4107,10 @@ getBuriedPreds (IAps ic@(ICon i_sel (ICSel { })) ts1 [e]) | (i_sel == idAVValue_ || i_sel == idAVAction_) = do --traceM("getBuriedPreds: AV sel") getBuriedPreds e +getBuriedPreds (ICon _ (ICMethod _ _ eb)) = do + -- traceM("getBuriedPreds: method") + p <- getBuriedPreds eb + return p getBuriedPreds e@(ICon _ _) = do --traceM("getBuriedPreds: con: e = " ++ ppReadable e ++ show e) return pTrue diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index 443a40b8c..d2e99be34 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -16,7 +16,7 @@ module IExpandUtils( pushIfcSchedNameScope, popIfcSchedNameScope, setIfcSchedNameScopeProgress, IfcElabProgress(..), addSubmodComments, {-getSubmodComments,-} - addPort, getPortWires, savePortType, saveTopModPortType, + addPort, getPortWires, savePortType, saveRules, getSavedRules, clearSavedRules, replaceSavedRules, setBackendSpecific, cacheDef, addStateVar, step, updHeap, getHeap, {- filterHeapPtrs, -} @@ -1224,9 +1224,6 @@ savePortType minst port t = do old_map put s { portTypeMap = new_map } -saveTopModPortType :: VName -> IType -> G () -saveTopModPortType port t = savePortType Nothing port t - -- --------------- saveRules :: (HClock, HReset) -> IStateLoc -> HPred -> HExpr -> G () diff --git a/src/comp/IfcBetterInfo.hs b/src/comp/IfcBetterInfo.hs index 555d7840d..103bf4082 100644 --- a/src/comp/IfcBetterInfo.hs +++ b/src/comp/IfcBetterInfo.hs @@ -31,8 +31,7 @@ data BetterInfo = BetterMethodInfo mi_result :: VPort, -- possible rename for method result mi_ready :: VPort, -- for ready signal mi_enable :: VPort, -- for enable signal - mi_prefix :: Id, -- default prefix for arguments (which are not found in classic) - mi_orig_type :: Maybe IType -- original (unwrapped) field type + mi_prefix :: Id -- default prefix for arguments (which are not found in classic) } -- XXX Note that the following are unused -- XXX (this package needs re-thinking) @@ -56,8 +55,7 @@ noMethodInfo fieldId = BetterMethodInfo {mi_id = fieldId, mi_result = id_to_vPort fieldId, mi_ready = id_to_vPort $ mkRdyId fieldId, mi_enable = id_to_vPort $ mkEnableId fieldId, - mi_prefix = fieldId, - mi_orig_type = Nothing + mi_prefix = fieldId } @@ -66,8 +64,7 @@ instance PPrint BetterInfo where ( printMaybe d i "Result:" (mi_result info) <> printMaybe d i "Ready:" (mi_ready info) <> printMaybe d i "Enable:" (mi_enable info) <> - text "Prefix:" <> pPrint d i (mi_prefix info) <> - printMaybe d i "Original type:" (mi_orig_type info) + text "Prefix:" <> pPrint d i (mi_prefix info) ) printMaybe :: PPrint a => PDetail -> Int -> String -> a -> Doc @@ -102,8 +99,7 @@ fieldInfoToBetterInfo flags symTab (fieldId, Just fi) = mi_result = maybe (id_to_vPort fieldId) (str_to_vPort) mres, mi_ready = maybe (id_to_vPort $ mkRdyId fieldId) str_to_vPort mrdy, mi_enable = maybe (id_to_vPort $ mkEnableId fieldId) str_to_vPort men, - mi_prefix = maybe fieldId (setIdBaseString fieldId) mprefix, - mi_orig_type = fmap (iConvT flags symTab) (fi_orig_type fi) + mi_prefix = maybe fieldId (setIdBaseString fieldId) mprefix } where prags = fi_pragmas fi (mprefix,mres,mrdy,men,_,_,_) = getMethodPragmaInfo prags From 57258ec190e2fba7f37ef9a7f906ad93ede03869 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Tue, 13 Aug 2024 10:24:35 -0700 Subject: [PATCH 06/43] Handle prefix for input port names via wrap typeclasses --- src/Libraries/Base1/Prelude.bs | 86 ++++++++++++++++++++++------------ src/comp/GenWrap.hs | 28 +++++------ src/comp/IExpand.hs | 10 +--- 3 files changed, 72 insertions(+), 52 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 51108ff1f..a19f01680 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4423,43 +4423,49 @@ instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {} -- Tag a method with metadata. -- Currently just the list of input port names. +-- Should eventually include the output port names, when we support multiple output ports. primitive primMethod :: List String -> a -> a class WrapField f w | f -> w where - -- Takes a list of argument names, converts a synthesized interface field value to + -- Given the prefix and arg_names pragmas, converts a synthesized interface field value to -- its wrapper interface field. - toWrapField :: List String -> f -> w + toWrapField :: String -> List String -> f -> w -- Converts a wrapper interface field value to its synthesized interface field. fromWrapField :: w -> f - -- Save the port types for a field in the wrapped interface. - saveFieldPortTypes :: f -> Maybe Name__ -> List String -> String -> Module () - saveFieldPortTypes _ _ _ _ = return () + -- Save the port types for a field in the wrapped interface, given the module name + -- and the prefix, arg_names and result pragmas. + saveFieldPortTypes :: f -> Maybe Name__ -> String -> List String -> String -> Module () + saveFieldPortTypes _ _ _ _ _ = return () instance (WrapMethod m w) => (WrapField m w) where - toWrapField names = primMethod (inputPortNames (_:: m) names) ∘ toWrapMethod + toWrapField prefix names = + let baseNames = methodArgBaseNames (_ :: m) prefix names 1 + in primMethod (inputPortNames (_ :: m) baseNames) ∘ toWrapMethod fromWrapField = fromWrapMethod - saveFieldPortTypes = saveMethodPortTypes + saveFieldPortTypes _ modName prefix names = + let baseNames = methodArgBaseNames (_ :: m) prefix names 1 + in saveMethodPortTypes (_ :: m) modName baseNames -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, -- but this case was being handled in GenWrap. instance WrapField PrimAction PrimAction where - toWrapField _ = id + toWrapField _ _ = id fromWrapField = id instance WrapField Clock Clock where - toWrapField _ = id + toWrapField _ _ = id fromWrapField = id instance WrapField Reset Reset where - toWrapField _ = id + toWrapField _ _ = id fromWrapField = id instance (Bits a n) => WrapField (Inout a) (Inout_ n) where - toWrapField _ = primInoutCast0 + toWrapField _ _ = primInoutCast0 fromWrapField = primInoutUncast0 - saveFieldPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) + saveFieldPortTypes _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: a) class WrapMethod m w | m -> w where -- Convert a synthesized interface method to its wrapper interface method. @@ -4468,35 +4474,46 @@ class WrapMethod m w | m -> w where -- Convert a wrapper interface method to its synthesized interface method. fromWrapMethod :: w -> m - -- Compute the list of input port names for a method, from its argument names. + -- Compute the actual argument base names for a method, given the prefix and arg_names pragmas. + methodArgBaseNames :: m -> String -> List String -> Integer -> List String + methodArgBaseNames _ _ _ _ = Nil + + -- Compute the list of input port names for a method, from the argument base names. inputPortNames :: m -> List String -> List String inputPortNames _ _ = Nil - -- Save the port types for a method. + -- Save the port types for a method, given the module name, argument base names and result name. saveMethodPortTypes :: m -> Maybe Name__ -> List String -> String -> Module () instance (SplitPorts a p, TupleSize p n, WrapPorts p pb, WrapMethod b v, Curry (pb -> v) w) => WrapMethod (a -> b) w where toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ unsplitPorts ∘ unpackPorts fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ packPorts ∘ splitPorts - inputPortNames _ (Cons h t) = - checkPortNames (_ :: a) h `listPrimAppend` - inputPortNames (_ :: b) t + + methodArgBaseNames _ prefix (Cons h t) i = Cons + (if prefix == "" && not (isDigit $ stringHead h) then h else prefix +++ "_" +++ h) + (methodArgBaseNames (_ :: b) prefix t $ i + 1) + methodArgBaseNames _ prefix Nil i = Cons + (prefix +++ "_" +++ integerToString i) + (methodArgBaseNames (_ :: b) prefix Nil $ i + 1) + + inputPortNames _ (Cons h t) = checkPortNames (_ :: a) h `listPrimAppend` inputPortNames (_ :: b) t inputPortNames _ Nil = error "inputPortNames: empty arg names list" - saveMethodPortTypes _ name (Cons h t) result = do - savePortTypes (_ :: p) name $ checkPortNames (_ :: a) h - saveMethodPortTypes (_ :: b) name t result + + saveMethodPortTypes _ modName (Cons h t) result = do + savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) h + saveMethodPortTypes (_ :: b) modName t result saveMethodPortTypes _ _ Nil _ = error "saveMethodPortTypes: empty arg names list" instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where toWrapMethod = toActionValue_ fromWrapMethod = fromActionValue_ - saveMethodPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) + saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a) instance (Bits a n) => WrapMethod a (Bit n) where toWrapMethod = pack fromWrapMethod = unpack - saveMethodPortTypes _ name _ result = primSavePortType name result $ typeOf (_ :: a) + saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a) {- Eventually, we should support splitting multiple output ports. @@ -4504,15 +4521,15 @@ instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod (ActionVa toWrapMethod = fmap packPorts fromWrapMethod = fmap unpackPorts outputPortNames _ base = checkPortNames (_ :: a) base - saveMethodPortTypes _ name _ result = - savePortTypes (_ :: p) name $ checkPortNames (_ :: a) result + saveMethodPortTypes _ modName _ result = + savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) result instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod a pb where toWrapMethod a = packPorts a fromWrapMethod a = unpackPorts a outputPortNames _ base = checkPortNames (_ :: a) base - saveMethodPortTypes _ name _ result = - savePortTypes (_ :: p) name $ checkPortNames (_ :: a) result + saveMethodPortTypes _ modName _ result = + savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) result -} class WrapPorts p pb | p -> pb where @@ -4526,15 +4543,15 @@ class WrapPorts p pb | p -> pb where instance (Bits a n, WrapPorts b bb) => WrapPorts (a, b) (Bit n, bb) where packPorts (a, b) = (pack a, packPorts b) unpackPorts (a, b) = (unpack a, unpackPorts b) - savePortTypes _ name (Cons h t) = do - primSavePortType name h $ typeOf (_ :: a) - savePortTypes (_ :: b) name t + savePortTypes _ modName (Cons h t) = do + primSavePortType modName h $ typeOf (_ :: a) + savePortTypes (_ :: b) modName t savePortTypes _ _ Nil = error "savePortTypes: empty port names list" instance (Bits a n) => WrapPorts a (Bit n) where packPorts = pack unpackPorts = unpack - savePortTypes _ name (Cons h _) = primSavePortType name h $ typeOf (_ :: a) + savePortTypes _ modName (Cons h _) = primSavePortType modName h $ typeOf (_ :: a) savePortTypes _ _ Nil = error "savePortTypes: empty port names list" instance WrapPorts () () where @@ -4542,6 +4559,9 @@ instance WrapPorts () () where unpackPorts _ = () savePortTypes _ _ _ = return () +-- Compute the list port names for type 'a' given a base name. +-- Check that the number of port names matches the number of ports. +-- This error should only occur if there is an error in a WrapPorts instance. checkPortNames :: (SplitPorts a p, TupleSize p n) => a -> String -> List String checkPortNames proxy base = let pn = portNames proxy base @@ -4552,8 +4572,14 @@ checkPortNames proxy base = else pn class SplitPorts a p | a -> p where + -- Convert a value to a tuple of values corresponding to ports. splitPorts :: a -> p + -- Combine a tuple of values corresponding to ports into a value. unsplitPorts :: p -> a + -- Compute the list of port names for a type, given a base name. + -- This must be the same length as the tuple of values. + -- XXX it would be nice to use ListN here to enforce this, but it's not + -- available in the Prelude. portNames :: a -> String -> List String -- XXX if the default instance is the only one, then it gets inlined in CtxReduce diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index d2db4dd2a..2178da074 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -9,7 +9,7 @@ module GenWrap( import Prelude hiding ((<>)) #endif -import Data.List(nub, (\\), find, genericLength) +import Data.List(nub, (\\), find) import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, gets, get, put) @@ -1064,14 +1064,14 @@ genTo pps ty mk = cint <- chkInterface ty case cint of Nothing -> internalError ("genTo: " ++ pfpReadable (ty, mk)) - Just (_, _, fts) -> do - meths <- mapM (meth mk noPrefixes) fts + Just (ifcId, _, fts) -> do + meths <- mapM (meth mk noPrefixes ifcId) fts fty <- flatTypeId pps ty let tmpl = Cinterface (getPosition fts) (Just fty) (concat meths) return tmpl where - meth :: CExpr -> IfcPrefixes -> FInf -> GWMonad [CDefl] - meth sel prefixes (FInf f as r aIds) = + meth :: CExpr -> IfcPrefixes -> Id -> FInf -> GWMonad [CDefl] + meth sel prefixes ifcId (FInf f as r aIds) = do mi <- chkInterface r case (mi, as) of @@ -1082,7 +1082,7 @@ genTo pps ty mk = else do --traceM ("selector: " ++ show sel) newPrefixes <- extendPrefixes prefixes [] r f - meths <- mapM (meth (extSel sel f) newPrefixes) fts + meths <- mapM (meth (extSel sel f) newPrefixes ifcId) fts return (concat meths) _ -> do -- Generate the Verilog template for X isVec <- isVectorInterfaces r @@ -1096,16 +1096,19 @@ genTo pps ty mk = elemPrefix <- extendPrefixes prefixes [] r f let recurse num = do numPrefix <- extendPrefixes elemPrefix [] r (mkNumId num) - meth (selector num) numPrefix (FInf idEmpty [] tVec []) + meth (selector num) numPrefix ifcId (FInf idEmpty [] tVec []) fields <- mapM recurse nums return (concat fields) _ -> do + ciPrags <- getInterfaceFieldPrags ifcId f + let currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix + localPrefix1 = fromMaybe (getIdString f) (lookupPrefixIfcPragma ciPrags) + localPrefix = joinStrings_ currentPre localPrefix1 + prefix = stringLiteralAt noPosition localPrefix + arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] -- XXX idEmpty is a horrible way to know no more selection is required - let arg_names = mkList - [stringLiteralAt (getPosition i) (getIdString i) - | i <- aIds ++ map mkNumId [genericLength aIds + 1..genericLength as]] let ec = if f == idEmpty then sel else CSelect sel (setInternal f) - let e = CApply (CVar id_toWrapField) [arg_names, ec] + let e = CApply (CVar id_toWrapField) [prefix, arg_names, ec] return [CLValue (binId prefixes f) [CClause [] [] e] []] -- -------------------- @@ -2149,9 +2152,6 @@ extSel :: CExpr -> Id -> CExpr extSel sel xid | xid == idEmpty = sel extSel sel xid = CSelect sel xid -cLams :: [Id] -> CExpr -> CExpr -cLams is e = foldr (CLam . Right) e is - unLams :: CExpr -> ([CPat], CExpr) unLams (CLam (Right i) e) = ((CPVar i):is, e') where (is, e') = unLams e unLams (CLam (Left p) e) = ((CPAny p):is, e') where (is, e') = unLams e diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 28bcdea0e..570c683a1 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1061,14 +1061,8 @@ iExpandMethodLam :: Id -> Integer -> [Id] -> HPred -> (HDef, HWireSet, VFieldInfo)) iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, eb) li ty p = do traceM ("iExpandMethodLam " ++ ppString i ++ " " ++ show ins) - let pfx :: Id - pfx = BetterInfo.mi_prefix bi - name :: String - name = head ins - i' :: Id - i' = if isEmptyId pfx && not (isDigit $ head name) - then mkIdPost pfx $ mkFString name - else mkIdPost pfx (concatFString [fsUnderscore, mkFString name]) + let i' :: Id + i' = mkId (getPosition i) $ mkFString $ head ins -- substitute argument with a modvar and replace with body eb' :: HExpr eb' = eSubst li (ICon i' (ICMethArg ty)) eb From 8fdb09d2c0dfe16af12cd308b1a46fd59b621b29 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Tue, 13 Aug 2024 14:09:37 -0700 Subject: [PATCH 07/43] Saving port types using WrapField type class method --- src/comp/GenWrap.hs | 115 +++++++++++++++++++++++++++++------------ src/comp/IExpand.hs | 4 +- src/comp/PreIds.hs | 3 +- src/comp/PreStrings.hs | 1 + 4 files changed, 86 insertions(+), 37 deletions(-) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 2178da074..68154c85a 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -10,7 +10,7 @@ import Prelude hiding ((<>)) #endif import Data.List(nub, (\\), find) -import Control.Monad(when, foldM, filterM, zipWithM, mapAndUnzipM) +import Control.Monad(when, foldM, filterM, zipWithM) import Control.Monad.Except(ExceptT, runExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, gets, get, put) import PFPrint @@ -25,6 +25,7 @@ import IdPrint import PreIds import CSyntax import CSyntaxUtil +import Undefined (UndefKind(..)) import SymTab(SymTab, TypeInfo(..), FieldInfo(..), findType, addTypesUQ, findField, findFieldInfo, getMethodArgNames) import MakeSymTab(convCQType) @@ -1296,11 +1297,17 @@ mkCtxs ty = mkNewModDef :: M.Map Id GeneratedIfc -> ModDefInfo -> GWMonad CDefn mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = do + --traceM ("mkNewModDef: " ++ ppReadable def) -- XXX This could have been stored in the moduledef info -- XXX (note that the first half is the "ts" in "vtis") let tr = case getArrows t of (_, TAp _ r) -> r _ -> internalError "GenWrap.mkNewModDef: tr" + cint <- chkInterface tr + (ifcId, _, fts) <- case cint of + Just res -> return res + Nothing -> internalError "GenWrap.mkNewModDef: cint" + tyId <- flatTypeId vps tr -- id of the Ifc_ let ty = tmod (cTCon tyId) -- type of new module @@ -1337,10 +1344,15 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = -- statements to record the port-types of module arguments -- (for the current module) arg_sptStmts = map (uncurry saveTopModPortTypeStmt) arg_pts + + -- interface save-port-type statements + ifc_sptStmts <- mkFieldSavePortTypeStmts Nothing ifcId fts + + let sptStmts = arg_sptStmts ++ ifc_sptStmts -- a do-block around the module body, so that we can include the -- save-port-type statements - lexp = if not (null arg_sptStmts) - then Cdo False (arg_sptStmts ++ [CSExpr Nothing mexp]) + lexp = if not (null sptStmts) + then Cdo False (sptStmts ++ [CSExpr Nothing mexp]) else mexp -- liftM of the do-block to = cVApply idLiftM [CVar (to_Id tyId), lexp] @@ -1433,7 +1445,7 @@ mkNewModDef _ (def,_,_,_) = -- This is the part of "genWrapInfo" which makes the DefFun, -- a continuation function which does the final wrapper computation. --- type DefFun = VWireInfo -> VSchedInfo -> VPathInfo -> [VPort] -> SymTab -> [VFieldInfo] -> [Id] -> [Id] -> IO CDefn +-- type DefFun = Bool -> VWireInfo -> VSchedInfo -> VPathInfo -> [VPort] -> SymTab -> [VFieldInfo] -> [Id] -> IO CDefn -- XXX: alwaysEnabled is dropped and broken (not propagated to {inhigh}) mkDef :: [PProp] -> [PProp] -> CDef -> CQType -> GWMonad DefFun mkDef iprags pps (CDef i (CQType _ qt) _) cqt = do @@ -1447,7 +1459,7 @@ mkDef iprags pps (CDef i (CQType _ qt) _) cqt = do -- do not use ifc prags here (st2, ti_) <- runGWMonadGetNoFail (flatTypeId pps tr) st1 let vs = take (length ts) tmpVarIds - (st3, Just (_, _, finfs)) <- runGWMonadGetNoFail (chkInterface tr) st2 + (st3, Just (ifcId, _, finfs)) <- runGWMonadGetNoFail (chkInterface tr) st2 let -- return an expression for creating the arg (from the wrapper's args) -- and the type of the internal module's arg (for port-type saving) @@ -1492,10 +1504,6 @@ mkDef iprags pps (CDef i (CQType _ qt) _) cqt = do -- make the arg port-types, for saving in the module arg_pts = mkArgPortTypes wire_info arg_ts let - -- don't use the "fixed up" veriFields below because we don't need - -- port property information (makes the flow a little simpler, I think) - vfield_map = M.fromList [(vf_name vf, vf) | vf <- fields] - fields' = filter (not . (isRdyToRemoveField (iprags ++ pps))) fields veriFields = (map (fixupVeriField (iprags ++ pps) ips) fields') vexp = xWrapperModuleVerilog @@ -1509,7 +1517,7 @@ mkDef iprags pps (CDef i (CQType _ qt) _) cqt = do pathinfo vlift = (cVApply idLiftModule [vexp]) body <- runGWMonadNoFail - (genFromBody arg_pts vfield_map vlift true_ifc_ids ti_ finfs) + (genFromBody arg_pts vlift true_ifc_ids ti_ ifcId finfs) st4 let cls = CClause (map CPVar vs) [] body return $ CValueSign (CDef i cqt [cls])) @@ -1534,24 +1542,21 @@ mkArgPortTypes wire_info arg_ts = -- used in wrapper generate to wrap the module given by mk -- to the result. -genFromBody :: [(VPort, CType)] -> M.Map Id VFieldInfo -> - CExpr -> [Id] -> Id -> [FInf] -> GWMonad CExpr -genFromBody arg_pts vfield_map mk true_ifc_ids si fts = +genFromBody :: [(VPort, CType)] -> + CExpr -> [Id] -> Id -> Id -> [FInf] -> GWMonad CExpr +genFromBody arg_pts mk true_ifc_ids si ifcId fts = do -- traceM( "genFromBody: " ++ ppReadable fts ) let sty = cTCon si let pos = getIdPosition si - let mkMethod = mkFromBind vfield_map true_ifc_ids (CVar (id_t pos)) - (meths, ifc_ptss) <- mapAndUnzipM mkMethod fts - -- TODO: Save "port types" for clocks, resets, inouts here. - let -- interface save-port-type statements - -- XXX need to use the type class here - ifc_sptStmts = - map (uncurry (savePortTypeStmt (CVar id_x))) (concat ifc_ptss) - -- argument save-port-type statements - arg_sptStmts = + let mkMethod = mkFromBind true_ifc_ids (CVar (id_t pos)) + meths <- mapM mkMethod fts + -- interface save-port-type statements + ifc_sptStmts <- mkFieldSavePortTypeStmts (Just $ CVar id_x) ifcId fts + -- argument save-port-type statements + let arg_sptStmts = map (uncurry (savePortTypeStmt (CVar id_x))) arg_pts - sptStmts = arg_sptStmts ++ ifc_sptStmts + sptStmts = arg_sptStmts ++ map CMStmt ifc_sptStmts let tmpl = Cmodule pos $ [CMStmt $ CSBindT (CPVar (id_t pos)) Nothing [] (CQType [] sty) mk] ++ ((saveNameStmt (id_t pos) id_x):sptStmts) ++ @@ -1560,25 +1565,24 @@ genFromBody arg_pts vfield_map mk true_ifc_ids si fts = return tmpl --- Creates a method for the module body --- also returns the raw port-type information for correlation +-- Creates a method for the module body. -- XXX some of this can be replaced with a call to "mkFrom_" -- Currently there is an optimization preventing this - we avoid adding guards for -- ready signals that are known to be constant True, which isn't known when mkFrom_ is generated. -mkFromBind :: M.Map Id VFieldInfo -> [Id] -> CExpr -> FInf -> GWMonad (CDefl, [(VPort, CType)]) -mkFromBind vfield_map true_ifc_ids var ft = +mkFromBind :: [Id] -> CExpr -> FInf -> GWMonad CDefl +mkFromBind true_ifc_ids var ft = do ms <- meth noPrefixes ft - return (mkv ms, fth4 ms) + return $ mkv ms where - mkv (f, e, g, _) = CLValue (setInternal f) [CClause vps [] e'] g + mkv (f, e, g) = CLValue (setInternal f) [CClause vps [] e'] g where (vps, e') = unLams e -- This returns a triple of a field Id (method or subifc), -- its definition, and its implicit condition (only for methods). -- Note: The Id is qualified, because it could be something not -- imported by the user (and this not available unqualified). - meth :: IfcPrefixes -> FInf -> GWMonad (Id, CExpr, [CQual], [(VPort, CType)]) + meth :: IfcPrefixes -> FInf -> GWMonad (Id, CExpr, [CQual]) meth prefixes (FInf f as r aIds) = do mi <- chkInterface r @@ -1586,7 +1590,7 @@ mkFromBind vfield_map true_ifc_ids var ft = (Just (ti, _, fts), []) -> do newprefixes <- extendPrefixes prefixes [] r f fieldBlobs <- mapM (meth newprefixes) fts - return (f, cInterface ti (map fst3of4 fieldBlobs), [], concatMap fth4 fieldBlobs) + return (f, cInterface ti fieldBlobs, []) _ -> do isVec <- isVectorInterfaces r case (isVec, as) of @@ -1596,9 +1600,9 @@ mkFromBind vfield_map true_ifc_ids var ft = let recurse num = do newprefixes <- extendPrefixes prefixes [] r f meth newprefixes (FInf (mkNumId num) [] tVec []) fieldBlobs <- mapM recurse nums - let (es, gs) = unzip [(e,g) | (_, e, g, _) <- fieldBlobs] + let (es, gs) = unzip [(e,g) | (_, e, g) <- fieldBlobs] let vec = cToVector isListN es - return (f, vec, concat gs, concatMap fth4 fieldBlobs) + return (f, vec, concat gs) _ -> do isPA <- isPrimAction r isClock <- isClockType r @@ -1612,7 +1616,7 @@ mkFromBind vfield_map true_ifc_ids var ft = let qs = if (wbinf `elem` true_ifc_ids || isClock || isReset || isIot) then [] else [CQFilter meth_guard] let e = CApply (CVar id_fromWrapField) [sel binf] - return (f, e, qs, []) + return (f, e, qs) @@ -2140,6 +2144,47 @@ saveTopModPortTypeStmt i t = cVApply idSavePortType [mkMaybe Nothing, stringLiteralAt noPosition s, typeLiteral t] +-- saveFieldPortTypes v "prefix" ["arg1", "arg2"] "result" +mkFieldSavePortTypeStmts :: Maybe CExpr -> Id -> [FInf] -> GWMonad [CStmt] +mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes + where + meth :: IfcPrefixes -> FInf -> GWMonad [CStmt] + meth prefixes (FInf f as r aIds) = + do + mi <- chkInterface r + case (mi, as) of + (Just (ti, _, fts), []) -> do + newprefixes <- extendPrefixes prefixes [] r f + concatMapM (meth newprefixes) fts + _ -> do + isVec <- isVectorInterfaces r + case (isVec, as) of + (Just (n, tVec, isListN), []) -> do + let nums = [0..(n-1)] :: [Integer] + let recurse num = do newprefixes <- extendPrefixes prefixes [] r f + meth newprefixes (FInf (mkNumId num) [] tVec []) + concatMapM recurse nums + _ -> do + ciPrags <- getInterfaceFieldPrags ifcId f + let methodStr = getIdString f + currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix + localPrefix1 = fromMaybe (getIdString f) (lookupPrefixIfcPragma ciPrags) + localPrefix = joinStrings_ currentPre localPrefix1 + mResName = lookupResultIfcPragma ciPrags + resultName = case mResName of + Just str -> joinStrings_ currentPre str + Nothing -> joinStrings_ currentPre methodStr + + proxy = mkProxy $ foldr arrow r as + prefix = stringLiteralAt noPosition localPrefix + arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] + result = stringLiteralAt noPosition resultName + return [ + CSExpr Nothing $ + cVApply id_saveFieldPortTypes + [proxy, mkMaybe v, prefix, arg_names, result]] + + saveNameStmt :: Id -> Id -> CMStmt saveNameStmt svName resultVar = CMStmt (CSletseq [(CLValue resultVar [CClause [] [] nameExpr]) []]) where nameExpr = cVApply idGetModuleName [cVApply idAsIfc [CVar svName]] @@ -2179,6 +2224,8 @@ tmod t = TAp (cTCon idModule) t id_t :: Position -> Id id_t pos = mkId pos fs_t +mkProxy :: CType -> CExpr +mkProxy ty = CHasType (CAny (getPosition ty) UNotUsed) $ CQType [] ty -- ==================== -- Ready method utilities diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 570c683a1..f77bfb4d4 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -21,7 +21,7 @@ import Data.List import Data.Maybe import Data.Foldable(foldrM) import Numeric(showIntAtBase) -import Data.Char(intToDigit, ord, chr, isDigit) +import Data.Char(intToDigit, ord, chr) import Control.Monad(when, foldM, zipWithM, mapAndUnzipM) import Control.Monad.Fix(mfix) --import Control.Monad.Fix @@ -1060,7 +1060,7 @@ iExpandMethodLam :: Id -> Integer -> [Id] -> HPred -> G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, eb) li ty p = do - traceM ("iExpandMethodLam " ++ ppString i ++ " " ++ show ins) + -- traceM ("iExpandMethodLam " ++ ppString i ++ " " ++ show ins) let i' :: Id i' = mkId (getPosition i) $ mkFString $ head ins -- substitute argument with a modvar and replace with body diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 980bfda04..24091731f 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -231,10 +231,11 @@ idPolyWrapField = mk_no fsPolyWrapField idLiftModule :: Id idLiftModule = prelude_id_no fsLiftModule -idWrapField, id_fromWrapField, id_toWrapField :: Id +idWrapField, id_fromWrapField, id_toWrapField, id_saveFieldPortTypes :: Id idWrapField = prelude_id_no fsWrapField id_fromWrapField = prelude_id_no fsFromWrapField id_toWrapField = prelude_id_no fsToWrapField +id_saveFieldPortTypes = prelude_id_no fsSaveFieldPortTypes -- Used by desugaring id_lam, id_if, id_read, id_write :: Position -> Id diff --git a/src/comp/PreStrings.hs b/src/comp/PreStrings.hs index 0fb91ca30..8cde6b751 100644 --- a/src/comp/PreStrings.hs +++ b/src/comp/PreStrings.hs @@ -345,6 +345,7 @@ fsPolyWrapField = mkFString "val" fsWrapField = mkFString "WrapField" fsFromWrapField = mkFString "fromWrapField" fsToWrapField = mkFString "toWrapField" +fsSaveFieldPortTypes = mkFString "saveFieldPortTypes" -- XXX low ASCII only, please... sAcute = "__" From 5945a7c52905816de1d17668f895b8172fac6198 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Tue, 13 Aug 2024 15:38:11 -0700 Subject: [PATCH 08/43] Bug fixes --- src/Libraries/Base1/Prelude.bs | 24 ++++++++++++++---------- src/comp/GenWrap.hs | 12 ++++++------ 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index a19f01680..99d97b276 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -256,7 +256,8 @@ package Prelude( MetaConsNamed(..), MetaConsAnon(..), MetaField(..), Curry(..), AppendTuple(..), AppendTuple'(..), TupleSize(..), - WrapField(..), WrapMethod(..), WrapPorts(..), SplitPorts(..), + WrapField(..), WrapMethod(..), WrapPorts(..), + Port(..), SplitPorts(..), primMethod ) where @@ -4540,17 +4541,17 @@ class WrapPorts p pb | p -> pb where -- Save the port types, given their names. savePortTypes :: p -> Maybe Name__ -> List String -> Module () -instance (Bits a n, WrapPorts b bb) => WrapPorts (a, b) (Bit n, bb) where - packPorts (a, b) = (pack a, packPorts b) - unpackPorts (a, b) = (unpack a, unpackPorts b) +instance (Bits a n, WrapPorts b bb) => WrapPorts (Port a, b) (Bit n, bb) where + packPorts (Port a, b) = (pack a, packPorts b) + unpackPorts (a, b) = (Port $ unpack a, unpackPorts b) savePortTypes _ modName (Cons h t) = do primSavePortType modName h $ typeOf (_ :: a) savePortTypes (_ :: b) modName t savePortTypes _ _ Nil = error "savePortTypes: empty port names list" -instance (Bits a n) => WrapPorts a (Bit n) where - packPorts = pack - unpackPorts = unpack +instance (Bits a n) => WrapPorts (Port a) (Bit n) where + packPorts (Port a) = pack a + unpackPorts = Port ∘ unpack savePortTypes _ modName (Cons h _) = primSavePortType modName h $ typeOf (_ :: a) savePortTypes _ _ Nil = error "savePortTypes: empty port names list" @@ -4582,6 +4583,9 @@ class SplitPorts a p | a -> p where -- available in the Prelude. portNames :: a -> String -> List String +data Port a = Port a + deriving (FShow) + -- XXX if the default instance is the only one, then it gets inlined in CtxReduce -- and other instances for this class are ignored. instance SplitPorts () () where @@ -4589,9 +4593,9 @@ instance SplitPorts () () where unsplitPorts = id portNames _ _ = Nil -instance SplitPorts a a where - splitPorts = id - unsplitPorts = id +instance SplitPorts a (Port a) where + splitPorts = Port + unsplitPorts (Port a) = a portNames _ base = Cons base Nil {- diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 68154c85a..e150df16b 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1103,7 +1103,7 @@ genTo pps ty mk = _ -> do ciPrags <- getInterfaceFieldPrags ifcId f let currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix - localPrefix1 = fromMaybe (getIdString f) (lookupPrefixIfcPragma ciPrags) + localPrefix1 = fromMaybe (getIdBaseString f) (lookupPrefixIfcPragma ciPrags) localPrefix = joinStrings_ currentPre localPrefix1 prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] @@ -2118,7 +2118,6 @@ chkUserPragmas pps ifc = do -- ==================== -- Saving name/type information --- XXX is liftModule really needed for these? -- liftModule $ primSavePortType (Valid v) s t savePortTypeStmt :: CExpr -> (VName, b) -> CType -> CMStmt @@ -2166,9 +2165,9 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes concatMapM recurse nums _ -> do ciPrags <- getInterfaceFieldPrags ifcId f - let methodStr = getIdString f + let methodStr = getIdBaseString f currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix - localPrefix1 = fromMaybe (getIdString f) (lookupPrefixIfcPragma ciPrags) + localPrefix1 = fromMaybe (getIdBaseString f) (lookupPrefixIfcPragma ciPrags) localPrefix = joinStrings_ currentPre localPrefix1 mResName = lookupResultIfcPragma ciPrags resultName = case mResName of @@ -2181,8 +2180,9 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes result = stringLiteralAt noPosition resultName return [ CSExpr Nothing $ - cVApply id_saveFieldPortTypes - [proxy, mkMaybe v, prefix, arg_names, result]] + cVApply idLiftModule $ + [cVApply id_saveFieldPortTypes + [proxy, mkMaybe v, prefix, arg_names, result]]] saveNameStmt :: Id -> Id -> CMStmt From 25695a44db7bdb40b06ca023ce5949e29b66cbee Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Wed, 14 Aug 2024 14:00:42 -0700 Subject: [PATCH 09/43] Use WrapField to determine noinline foreign function types --- src/comp/CSyntax.hs | 9 ++-- src/comp/CVPrint.hs | 2 +- src/comp/GenBin.hs | 9 ++-- src/comp/GenFuncWrap.hs | 47 ++++--------------- src/comp/GenSign.hs | 4 +- src/comp/MakeSymTab.hs | 6 ++- src/comp/Parser/Classic/CParser.hs | 2 +- src/comp/Parser/Classic/Warnings.hs | 2 +- src/comp/bluetcl.hs | 2 +- ...ne_ArgNotInBits.bsv.bsc-vcomp-out.expected | 22 +++++---- ...ne_ResNotInBits.bsv.bsc-vcomp-out.expected | 27 +++++++---- testsuite/bsc.verilog/noinline/noinline.exp | 7 ++- 12 files changed, 64 insertions(+), 75 deletions(-) diff --git a/src/comp/CSyntax.hs b/src/comp/CSyntax.hs index 9f43ad839..8fa1462e0 100644 --- a/src/comp/CSyntax.hs +++ b/src/comp/CSyntax.hs @@ -152,7 +152,8 @@ data CDefn | Cforeign { cforg_name :: Id, cforg_type :: CQType, cforg_foreign_name :: Maybe String, - cforg_ports :: Maybe ([String], [String]) } + cforg_ports :: Maybe ([String], [String]), + cforg_is_noinline :: Bool } | Cprimitive Id CQType | CprimType IdK | CPragma Pragma @@ -964,8 +965,10 @@ instance PPrint CDefn where (IdK i) -> ppConId d i (IdKind i k) -> ppConId d i <+> t "::" <+> pp d k (IdPKind i pk) -> ppConId d i <+> t "::" <+> pp d pk - pPrint d p (Cforeign i ty oname opnames) = - text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os))) + pPrint d p (Cforeign i ty oname opnames _) = + text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> + (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> + (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os))) where po [o] = [text ",", text (show o)] po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] pPrint d p (CIinstance i qt) = diff --git a/src/comp/CVPrint.hs b/src/comp/CVPrint.hs index 8f97ace07..100b93685 100644 --- a/src/comp/CVPrint.hs +++ b/src/comp/CVPrint.hs @@ -287,7 +287,7 @@ instance PVPrint CDefn where pvPrint d p (CprimType (IdKind i k)) = t"primitive type" <+> pp d i <+> t "::" <+> pp d k - pvPrint d p (Cforeign i ty oname opnames) = + pvPrint d p (Cforeign i ty oname opnames _) = text "foreign" <+> pvpId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> empty; Just s -> text (" = " ++ show s)) diff --git a/src/comp/GenBin.hs b/src/comp/GenBin.hs index e7dfe642d..1e9ca1162 100644 --- a/src/comp/GenBin.hs +++ b/src/comp/GenBin.hs @@ -27,7 +27,7 @@ doTrace = elem "-trace-genbin" progArgs -- .bo file tag -- change this whenever the .bo format changes -- See also GenABin.header header :: [Byte] -header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20230831-1" +header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20240814-1" genBinFile :: ErrorHandle -> String -> CSignature -> CSignature -> IPackage a -> IO () @@ -84,8 +84,8 @@ instance Bin CDefn where do putI 2; toBin vis; toBin st; toBin ik; toBin is; toBin fs writeBytes (Cclass incoh ps ik is deps fs) = do putI 3; toBin incoh; toBin ps; toBin ik; toBin is; toBin deps; toBin fs - writeBytes (Cforeign n cqt fn ports) = - do putI 4; toBin n; toBin cqt; toBin fn; toBin ports + writeBytes (Cforeign n cqt fn ports ni) = + do putI 4; toBin n; toBin cqt; toBin fn; toBin ports; toBin ni writeBytes (Cprimitive i cqt) = do putI 5; toBin i; toBin cqt writeBytes (CprimType ik) = do putI 6; toBin ik writeBytes (CIinstance i cqt) = do putI 7; toBin i; toBin cqt @@ -128,7 +128,8 @@ instance Bin CDefn where cqt <- fromBin fn <- fromBin ports <- fromBin - return (Cforeign n cqt fn ports) + ni <- fromBin + return (Cforeign n cqt fn ports ni) 5 -> do when doTrace $ traceM ("Cprimitive") i <- fromBin; cqt <- fromBin return (Cprimitive i cqt) diff --git a/src/comp/GenFuncWrap.hs b/src/comp/GenFuncWrap.hs index 1a33d6f27..ef173c822 100644 --- a/src/comp/GenFuncWrap.hs +++ b/src/comp/GenFuncWrap.hs @@ -9,14 +9,13 @@ import Error(internalError, ErrMsg(..), ErrorHandle, bsError) import Flags(Flags) import PPrint import Id -import PreIds(idBits, idUnpack, idPack, tmpVarIds, - idActionValue, idFromActionValue_) +import PreIds(id_fromWrapField, idActionValue) import CSyntax import SymTab import Scheme import Assump import Type(tModule, fn) -import CType(getArrows, cTVarNum) +import CType(getArrows, getRes) import Pred(expandSyn) import TypeCheck(cCtxReduceDef) import Subst(tv) @@ -241,48 +240,20 @@ addFuncWrap errh symt is (CPackage modid exps imps fixs ds includes) = do -- n = the number of arguments to the foreign function -- t = the base type of the foreign function funcDef :: ErrorHandle -> SymTab -> Id -> CQType -> Id -> Int -> CQType -> IO CDefn -funcDef errh symt i oqt@(CQType octxs ot) i_ n (CQType _ t) = - let - -- unfortunately, we have to duplicate the work that genwrap did - -- in creating the interface interface type and interface - -- conversion functions - - pos = getPosition i - (as, r) = getArrows ot - - -- the arguments are always bitifiable - bitsCtx a s = CPred (CTypeclass idBits) [a, s] - size_vars = map (cTVarNum . enumId "sn" pos) [0..] - as_ctxs = zipWith bitsCtx as size_vars - - vs = map (setIdPosition pos) $ take n tmpVarIds - epack e = cVApply idPack [e] - es = map (epack . CVar) vs - - f_expr = cVApply i_ es - +funcDef errh symt i oqt@(CQType _ ot) i_ n (CQType _ t) = + let pos = getPosition i + r = getRes ot -- the result is either an actionvalue or a value isAV = isActionValue symt r - r_size_var = cTVarNum $ enumId "sn" pos n - r_ctxs = case (isAV) of - Just av_t -> [bitsCtx av_t r_size_var] - Nothing -> [bitsCtx r r_size_var] - - expr = if (isJust isAV) - then cVApply idFromActionValue_ [f_expr] - else cVApply idUnpack [f_expr] - - -- put the ctxs together - ctxs' = as_ctxs ++ r_ctxs ++ octxs - qt' = CQType ctxs' ot + expr = cVApply id_fromWrapField [CVar i_] in -- XXX this code works for Action/ActionValue foreign funcs, -- XXX but they are not handled by astate yet if (isJust isAV) - then bsError errh [(getPosition i, ENoInlineAction (getIdBaseString i))] + then bsError errh [(pos, ENoInlineAction (getIdBaseString i))] else return $ - CValueSign (CDef i qt' [CClause (map CPVar vs) [] expr]) + CValueSign (CDef i oqt [CClause [] [] expr]) -- --------------- @@ -304,7 +275,7 @@ funcDef_ mi i i_ qt_ args = -- output port: oport = getIdString i in - Cforeign i_ qt_ (Just mstr) (Just (iports, [oport])) + Cforeign i_ qt_ (Just mstr) (Just (iports, [oport])) True -- --------------- diff --git a/src/comp/GenSign.hs b/src/comp/GenSign.hs index cf4c54b9a..0161e839f 100644 --- a/src/comp/GenSign.hs +++ b/src/comp/GenSign.hs @@ -407,11 +407,11 @@ genDefSign s look currentPkg (CValueSign (CDef i qt _)) = in case look qi of Nothing -> [] Just _ -> [(CIValueSign qi (qualCQType s qt), [])] -genDefSign s look currentPkg (Cforeign i qt ms mps) = +genDefSign s look currentPkg (Cforeign i qt ms mps ni) = let qi = qualId currentPkg i in case look qi of Nothing -> [] - Just _ -> [(Cforeign qi (qualCQType s qt) ms mps, [])] + Just _ -> [(Cforeign qi (qualCQType s qt) ms mps ni, [])] genDefSign s look currentPkg (Cprimitive i qt) = let qi = qualId currentPkg i in case look qi of diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 99439463a..963d6e983 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -602,7 +602,7 @@ chkTopDef r mi isDep (Cprimitive i ct) = do chkTopDef r mi isDep (CIValueSign i ct) = do sc <- mkSchemeWithSymTab r ct return [(i, VarInfo VarDefn (i :>: sc) (isDep i))] -chkTopDef r mi isDep (Cforeign i qt on ops) = do +chkTopDef r mi isDep (Cforeign i qt on ops ni) = do sc@(Forall _ (_ :=> t)) <- mkSchemeWithSymTab r qt let name = case on of Just s -> s @@ -622,7 +622,9 @@ chkTopDef r mi isDep (Cforeign i qt on ops) = do in (all isGoodArg args) && (isGoodResult res) let i' = qual mi i - if isGoodType (expandSyn t) then + -- This check is skipped for noinline-created foreign functions, since their type is + -- determined by the WrapField type class, and a bad foreign type will raise an error in typecheck. + if ni || isGoodType (expandSyn t) then return [(i', VarInfo (VarForg name ops) (i' :>: sc) (isDep i))] else throwError (getPosition i, EForeignNotBit (pfpString i)) diff --git a/src/comp/Parser/Classic/CParser.hs b/src/comp/Parser/Classic/CParser.hs index c0ea63e46..78a4ad799 100644 --- a/src/comp/Parser/Classic/CParser.hs +++ b/src/comp/Parser/Classic/CParser.hs @@ -406,7 +406,7 @@ pVarDefn = (pVarId +.+ dc ..+ pQType +.. dsm `into` \(var, typ) -> pClauses1 v pTyDefn :: Bool -> CParser CDefn pTyDefn b = l L_foreign ..+ pVarId +.+ dc ..+ pQType +.+ opt (eq ..+ pString) +.+ opt (cm ..+ lp ..+ many pString +.+ pForeignRes +.. rp) - >>>>> Cforeign + >>>>> (\ i qt on ops -> Cforeign i qt on ops True) ||! l L_primitive ..+ pVarId +.+ dc ..+ pQType >>> Cprimitive -- ||! l L_primitive ..+ l L_class ..+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps >>>>> CprimClass ||! l L_primitive ..+ l L_type ..+ pTyConId +.+ dc ..+ pKind >>- (\ (i, k) -> CprimType (IdKind i k)) diff --git a/src/comp/Parser/Classic/Warnings.hs b/src/comp/Parser/Classic/Warnings.hs index 7f68511da..ea0b447d5 100644 --- a/src/comp/Parser/Classic/Warnings.hs +++ b/src/comp/Parser/Classic/Warnings.hs @@ -32,7 +32,7 @@ classicWarnings (CPackage _ _ _ _ ds _) = concatMap getWarnings ds getBound (CValue i _) = [i] getBound (CValueSign (CDef i _ _)) = [i] getBound (CValueSign (CDefT i _ _ _)) = [i] - getBound (Cforeign i _ _ _) = [i] + getBound (Cforeign i _ _ _ _) = [i] getBound (Cprimitive i _) = [i] getBound (CprimType {}) = [] getBound (CPragma {}) = [] diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index 7353ebcbe..3596ebf09 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -788,7 +788,7 @@ tclDefs xs = internalError $ "tclDefs: grammar mismatch: " ++ (show xs) -- XXX the argument names and we could display them. displayCDefn :: CDefn -> [HTclObj] displayCDefn (CIValueSign i cqt) = [displayTypeSignature i cqt] -displayCDefn (Cforeign i cqt _ _) = [displayTypeSignature i cqt] +displayCDefn (Cforeign i cqt _ _ _) = [displayTypeSignature i cqt] displayCDefn (Cprimitive i cqt) = [displayTypeSignature i cqt] displayCDefn (CValue i _) = internalError ("displayCDefn: unexpected CValue: " ++ ppReadable i) diff --git a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected index 06ba4d213..727783b2d 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected @@ -1,11 +1,15 @@ checking package dependencies compiling NoInline_ArgNotInBits.bsv -code generation for module_fnNoInline_ArgNotInBits starts -Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0043) - Cannot synthesize `module_fnNoInline_ArgNotInBits': The interface method - `fnNoInline_ArgNotInBits' uses type `NoInline_ArgNotInBits::L' which is not - in the Bits class. - During elaboration of the interface method `fnNoInline_ArgNotInBits' at - "NoInline_ArgNotInBits.bsv", line 4, column 15. - During elaboration of `module_fnNoInline_ArgNotInBits' at - "NoInline_ArgNotInBits.bsv", line 4, column 15. +Error: Unknown position: (T0031) + The provisos for this expression could not be resolved because there are no + instances of the form: + Bits#(NoInline_ArgNotInBits::L, a__) + The proviso was implied by expressions at the following positions: + "NoInline_ArgNotInBits.bsv", line 4, column 15 +Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0032) + This expression requires the following proviso which could not be resolved: + WrapField#(function Bool f(NoInline_ArgNotInBits::L x1), a__) + An instance for this proviso exists, but it depends on the following + provisos for which there are no instances: + Curry#(function Bit#(1) f(Bit#(b__) x1), a__), + Bits#(NoInline_ArgNotInBits::L, b__) diff --git a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected index 02d3fb3c6..75030a887 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected @@ -1,11 +1,20 @@ checking package dependencies compiling NoInline_ResNotInBits.bsv -code generation for module_fnNoInline_ResNotInBits starts -Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0043) - Cannot synthesize `module_fnNoInline_ResNotInBits': The interface method - `fnNoInline_ResNotInBits' uses type `NoInline_ResNotInBits::L' which is not - in the Bits class. - During elaboration of the interface method `fnNoInline_ResNotInBits' at - "NoInline_ResNotInBits.bsv", line 4, column 12. - During elaboration of `module_fnNoInline_ResNotInBits' at - "NoInline_ResNotInBits.bsv", line 4, column 12. +Error: Unknown position: (T0031) + The provisos for this expression could not be resolved because there are no + instances of the form: + Bits#(NoInline_ResNotInBits::L, a__) + The proviso was implied by expressions at the following positions: + "NoInline_ResNotInBits.bsv", line 4, column 12 +Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0032) + This expression requires the following proviso which could not be resolved: + WrapField#(function NoInline_ResNotInBits::L f(Bool x1), a__) + An instance for this proviso exists, but it depends on the following proviso + for which there is no instance: + Bits#(NoInline_ResNotInBits::L, b__) +Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0029) + Signature mismatch (given too general): + given: + function b__ f(Bit#(1) x1) provisos (Bits#(NoInline_ResNotInBits::L, a__)) + deduced: + function Bit#(c__) f(Bit#(1) x1) provisos (Bits#(NoInline_ResNotInBits::L, c__)) diff --git a/testsuite/bsc.verilog/noinline/noinline.exp b/testsuite/bsc.verilog/noinline/noinline.exp index 78b24f4a2..598f7c411 100644 --- a/testsuite/bsc.verilog/noinline/noinline.exp +++ b/testsuite/bsc.verilog/noinline/noinline.exp @@ -44,8 +44,7 @@ test_c_veri_bsv_modules \ # The typedef fails because BSC doesn't expand the synonym before checking # to see if the result type is in Bits, so the user gets a proviso error # (bug 1466) -compile_verilog_pass_bug_error \ - NoInline_LessPatternsThanArgs_BSV_TypeDef.bsv T0031 +compile_verilog_pass NoInline_LessPatternsThanArgs_BSV_TypeDef.bsv # ----- @@ -60,11 +59,11 @@ test_c_veri_bsv_modules NoInlineInSched {module_inv} if { $vtest == 1 } { -compile_verilog_fail_error NoInline_ArgNotInBits.bsv T0043 +compile_verilog_fail_error NoInline_ArgNotInBits.bsv T0031 # compare for good measure, since the error has a configurable string compare_file NoInline_ArgNotInBits.bsv.bsc-vcomp-out -compile_verilog_fail_error NoInline_ResNotInBits.bsv T0043 +compile_verilog_fail_error NoInline_ResNotInBits.bsv T0031 # compare for good measure, since the error has a configurable string compare_file NoInline_ResNotInBits.bsv.bsc-vcomp-out From 6568cc8d643c7275a8f43a554d7aedfa66fe4d19 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Wed, 14 Aug 2024 16:23:06 -0700 Subject: [PATCH 10/43] Cleanup, add DeepSplitPorts type class --- src/Libraries/Base1/Prelude.bs | 186 +++++++++++++++++++++++---------- src/Libraries/Base1/Vector.bs | 14 +++ 2 files changed, 142 insertions(+), 58 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 99d97b276..8247bc7bd 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -94,7 +94,7 @@ package Prelude( primCharToString, primUIntBitsToInteger, primIntBitsToInteger, - ($), (∘), id, const, constFn, flip, while, curry, uncurry, asTypeOf, + ($), (∘), id, const, constFn, flip, while, curry, uncurry, Curry(..), asTypeOf, liftM, liftM2, bindM, (<+>), rJoin, @@ -171,6 +171,7 @@ package Prelude( Tuple6, tuple6, Has_tpl_6(..), Tuple7, tuple7, Has_tpl_7(..), Tuple8, tuple8, Has_tpl_8(..), + AppendTuple(..), AppendTuple'(..), TupleSize(..), -- lists required for desugaring List(..), @@ -255,10 +256,9 @@ package Prelude( Meta(..), MetaData(..), StarArg(..), NumArg(..), StrArg(..), ConArg(..), MetaConsNamed(..), MetaConsAnon(..), MetaField(..), - Curry(..), AppendTuple(..), AppendTuple'(..), TupleSize(..), - WrapField(..), WrapMethod(..), WrapPorts(..), + primMethod, WrapField(..), WrapMethod(..), WrapPorts(..), Port(..), SplitPorts(..), - primMethod + DeepSplit(..), DeepSplitPorts(..), DeepSplitPorts'(..), DeepSplitPorts''(..) ) where infixr 0 $ @@ -2594,6 +2594,23 @@ curry f x y = f (x, y) uncurry :: (a -> b -> c) -> ((a, b) -> c) uncurry f (x, y) = f x y +-- Polymorphic, N-argument version of curry/uncurry +class Curry f g | f -> g where + curryN :: f -> g + uncurryN :: g -> f + +instance (Curry (b -> c) d) => Curry ((a, b) -> c) (a -> d) where + curryN f x = curryN $ \y -> f (x, y) + uncurryN f (x, y) = uncurryN (f x) y + +instance Curry (() -> a) a where + curryN f = f () + uncurryN f _ = f + +instance Curry (a -> b) (a -> b) where + curryN = id + uncurryN = id + --@ Constant function --@ \index{const@\te{const} (Prelude function)} --@ \begin{libverbatim} @@ -3377,6 +3394,43 @@ tuple7 a b c d e f g = (a,b,c,d,e,f,g) tuple8 :: a -> b -> c -> d -> e -> f -> g -> h -> Tuple8 a b c d e f g h tuple8 a b c d e f g h = (a,b,c,d,e,f,g,h) +class AppendTuple a b c | a b -> c where + appendTuple :: a -> b -> c + splitTuple :: c -> (a, b) + +instance AppendTuple a () a where + appendTuple x _ = x + splitTuple x = (x, ()) + +-- The above instance should take precedence over the other cases that assume +-- b is non-unit. To avoid overlapping instances, the below are factored out as +-- a seperate type class: +instance (AppendTuple' a b c) => AppendTuple a b c where + appendTuple = appendTuple' + splitTuple = splitTuple' + +class AppendTuple' a b c | a b -> c where + appendTuple' :: a -> b -> c + splitTuple' :: c -> (a, b) + +instance AppendTuple' () a a where + appendTuple' _ = id + splitTuple' x = ((), x) + +instance AppendTuple' a b (a, b) where + appendTuple' a b = (a, b) + splitTuple' = id + +instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where + appendTuple' (x, y) z = (x, appendTuple' y z) + splitTuple' (x, y) = case splitTuple' y of + (w, z) -> ((x, w), z) + +class TupleSize a n | a -> n where {} +instance TupleSize () 0 where {} +instance TupleSize a 1 where {} +instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {} + -- FUNCTIONS TO REPLACE UNAVAILABLE INFIXES compose :: (b -> c) -> (a -> b) -> (a -> c) @@ -4377,51 +4431,6 @@ data (MetaField :: $ -> # -> *) name idx = MetaField deriving (FShow) -class Curry f g | f -> g where - curryN :: f -> g - uncurryN :: g -> f - -instance (Curry (b -> c) d) => Curry ((a, b) -> c) (a -> d) where - curryN f x = curryN $ \y -> f (x, y) - uncurryN f (x, y) = uncurryN (f x) y - -instance Curry (() -> a) a where - curryN f = f () - uncurryN f _ = f - -instance Curry (a -> b) (a -> b) where - curryN = id - uncurryN = id - -class AppendTuple a b c | a b -> c where - appendTuple :: a -> b -> c - -instance AppendTuple a () a where - appendTuple x _ = x - --- The above instance should take precedence over the other cases that assume --- b is non-unit. To avoid overlapping instances, the below are factored out as --- a seperate type class: -instance (AppendTuple' a b c) => AppendTuple a b c where - appendTuple = appendTuple' - -class AppendTuple' a b c | a b -> c where - appendTuple' :: a -> b -> c - -instance AppendTuple' () a a where - appendTuple' _ = id - -instance AppendTuple' a b (a, b) where - appendTuple' a b = (a, b) - -instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where - appendTuple' (x, y) z = (x, appendTuple' y z) - -class TupleSize a n | a -> n where {} -instance TupleSize () 0 where {} -instance TupleSize a 1 where {} -instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {} - -- Tag a method with metadata. -- Currently just the list of input port names. -- Should eventually include the output port names, when we support multiple output ports. @@ -4598,12 +4607,73 @@ instance SplitPorts a (Port a) where unsplitPorts (Port a) = a portNames _ base = Cons base Nil -{- -instance WrapPorts (Vector 0 a) () where - toPorts _ = () - fromPorts _ = nil - -instance (Add n1 1 n, WrapPorts a p1, WrapPorts (Vector n1 a) p2, AppendTuple p1 p2 p) => - WrapPorts (Vector n a) p where - toPorts v = appendTuple (toPorts $ head v) (toPorts $ tail v) --} \ No newline at end of file +-- Newtype tag to indicate that a type should be recursively split into ports +data DeepSplit a = DeepSplit a + +instance (DeepSplitPorts a p) => SplitPorts (DeepSplit a) p where + splitPorts (DeepSplit x) = deepSplitPorts x + unsplitPorts = DeepSplit ∘ deepUnsplitPorts + portNames _ = deepSplitPortNames (_ :: a) + + +-- Helper class using generics, to recursively split structs and vectors into a tuple of ports. +class DeepSplitPorts a p | a -> p where + deepSplitPorts :: a -> p + deepUnsplitPorts :: p -> a + deepSplitPortNames :: a -> String -> List String + +instance (Generic a r, DeepSplitPorts' r a p) => + DeepSplitPorts a p where + deepSplitPorts = deepSplitPorts' (_ :: r) + deepUnsplitPorts = deepUnsplitPorts' (_ :: r) + deepSplitPortNames = deepSplitPortNames' (_ :: r) + +class DeepSplitPorts' r a p | r a -> p where + deepSplitPorts' :: r -> a -> p + deepUnsplitPorts' :: r -> p -> a + deepSplitPortNames' :: r -> a -> String -> List String + +instance (SplitPorts a p) => DeepSplitPorts' r a p where + deepSplitPorts' _ = splitPorts + deepUnsplitPorts' _ = unsplitPorts + deepSplitPortNames' _ = portNames + +instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where + deepSplitPorts' _ = deepSplitPorts'' ∘ from + deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' + deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: r) + +class DeepSplitPorts'' r p | r -> p where + deepSplitPorts'' :: r -> p + deepUnsplitPorts'' :: p -> r + deepSplitPortNames'' :: r -> String -> List String + +instance (DeepSplitPorts'' a p, DeepSplitPorts'' b q, AppendTuple p q r) => DeepSplitPorts'' (a, b) r where + deepSplitPorts'' (a, b) = deepSplitPorts'' a `appendTuple` deepSplitPorts'' b + deepUnsplitPorts'' x = case splitTuple x of + (a, b) -> (deepUnsplitPorts'' a, deepUnsplitPorts'' b) + deepSplitPortNames'' _ base = + deepSplitPortNames'' (_ :: a) base `listPrimAppend` deepSplitPortNames'' (_ :: b) base + +instance DeepSplitPorts'' () () where + deepSplitPorts'' _ = () + deepUnsplitPorts'' _ = () + deepSplitPortNames'' _ _ = Nil + +instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta (MetaField name idx) r) p where + deepSplitPorts'' (Meta x) = deepSplitPorts'' x + deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' + deepSplitPortNames'' _ base = deepSplitPortNames'' (_ :: r) $ + if stringHead (stringOf name) == '_' + then base +++ stringOf name + else base +++ "_" +++ stringOf name + +instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta m r) p where + deepSplitPorts'' (Meta x) = deepSplitPorts'' x + deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' + deepSplitPortNames'' _ = deepSplitPortNames'' (_ :: r) + +instance (DeepSplitPorts a p) => DeepSplitPorts'' (Conc a) p where + deepSplitPorts'' (Conc x) = deepSplitPorts x + deepUnsplitPorts'' = Conc ∘ deepUnsplitPorts + deepSplitPortNames'' _ = deepSplitPortNames (_ :: a) diff --git a/src/Libraries/Base1/Vector.bs b/src/Libraries/Base1/Vector.bs index 70d410993..6006abd41 100644 --- a/src/Libraries/Base1/Vector.bs +++ b/src/Libraries/Base1/Vector.bs @@ -1362,3 +1362,17 @@ instance (PrimMakeUninitialized'' r) => PrimMakeUninitialized'' (Vector n r) whe instance (PrimDeepSeqCond' r) => PrimDeepSeqCond' (Vector n r) where primDeepSeqCond' = flip $ foldr primDeepSeqCond' + +instance DeepSplitPorts'' (Vector 0 r) () where + deepSplitPorts'' _ = () + deepUnsplitPorts'' _ = nil + deepSplitPortNames'' _ _ = Nil + +instance (DeepSplitPorts'' r p1, Add n1 1 n, DeepSplitPorts'' (Vector n1 r) p2, AppendTuple p1 p2 p) => + DeepSplitPorts'' (Vector n r) p where + deepSplitPorts'' v = deepSplitPorts'' (head v) `appendTuple` deepSplitPorts'' (tail v) + deepUnsplitPorts'' x = case splitTuple x of + (y, z) -> deepUnsplitPorts'' y :> deepUnsplitPorts'' z + deepSplitPortNames'' _ base = + let genElem i = deepSplitPortNames'' (_ :: r) (base +++ "_" +++ integerToString i) + in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) From 1b1f033e4aac2a1e9f6e89e502088fe14f4544ec Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 11:18:50 -0700 Subject: [PATCH 11/43] Add primMethod wrapper prim calls in vMkRWire1 --- src/Libraries/Base1/PreludeBSV.bsv | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Libraries/Base1/PreludeBSV.bsv b/src/Libraries/Base1/PreludeBSV.bsv index 22e12f124..046e2c349 100644 --- a/src/Libraries/Base1/PreludeBSV.bsv +++ b/src/Libraries/Base1/PreludeBSV.bsv @@ -88,15 +88,17 @@ interface VRWireN#(numeric type n); endinterface // for addCFWire desugaring +// This uses prim types like something coming from genwrap. module vMkRWire1(VRWireN#(1)); (* hide *) VRWire#(Bit#(1)) _rw <- vMkRWire; - method wset(v); - return(toPrimAction(_rw.wset(v))); - endmethod - method wget = _rw.wget; - method whas = pack(_rw.whas); + function rw_wset(v); + return toPrimAction(_rw.wset(v)); + endfunction + method wset = primMethod(Cons("v", Nil), rw_wset); + method wget = primMethod(Nil, _rw.wget); + method whas = primMethod(Nil, pack(_rw.whas)); endmodule From 730f044fea2e5a4fff5b8e912d5a69c50e121d44 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 11:59:07 -0700 Subject: [PATCH 12/43] Update expected test output --- .../urgency/IfcIfcWarning.bsv.bsc-sched-out.expected | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/testsuite/bsc.scheduler/urgency/IfcIfcWarning.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/urgency/IfcIfcWarning.bsv.bsc-sched-out.expected index 27c0fa197..9644c77f8 100644 --- a/testsuite/bsc.scheduler/urgency/IfcIfcWarning.bsv.bsc-sched-out.expected +++ b/testsuite/bsc.scheduler/urgency/IfcIfcWarning.bsv.bsc-sched-out.expected @@ -8,7 +8,8 @@ order: [bar, baz] ----- === resources: -[(the_r.read, [(the_r.read, 1)]), (the_r.write, [(the_r.write x__h69, 1), (the_r.write x__h85, 1)])] +[(the_r.read, [(the_r.read, 1)]), + (the_r.write, [(the_r.write x__h108, 1), (the_r.write x__h134, 1)])] ----- From 7975da73f5430da966a3adc156e9e30a231950d4 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 14:18:13 -0700 Subject: [PATCH 13/43] Re-add module arg port type saving, still need to do port name conflict checking --- src/comp/GenWrap.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index e150df16b..1b3774550 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1324,11 +1324,11 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = ftps <- mapM collectIfcInfo (reverse cfields) -- get back the arg port to type mapping, for recording flgs <- getFlags - -- XXX Need to handle module arguments here. -- XXX Need to sanity check port names after elaboration. -- arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps - let arg_pts = [] - + let arg_pts = + [ (pid,pt) | (pid,pt,Simple {}) <- vtis, not $ isParamModArg vps pid || pt == tClock && pt == tReset ] ++ + [ (pid,pt) | (_,_,Vector _ _ _ ais) <- vtis, (pid,pt) <- concatMap extractVTPairs ais ] let arg_infos = thd $ unzip3 vtis (vs, ts) = unzip $ concatMap extractVTPairs arg_infos From 3ba06d472ef96cbe22994f9eafe1ff31e50f87d1 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 14:23:10 -0700 Subject: [PATCH 14/43] Fix saving Inout port types --- src/Libraries/Base1/Prelude.bs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 8247bc7bd..cb0afbbeb 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4475,7 +4475,7 @@ instance WrapField Reset Reset where instance (Bits a n) => WrapField (Inout a) (Inout_ n) where toWrapField _ _ = primInoutCast0 fromWrapField = primInoutUncast0 - saveFieldPortTypes _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: a) + saveFieldPortTypes _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: (Inout a)) class WrapMethod m w | m -> w where -- Convert a synthesized interface method to its wrapper interface method. From 96c35e5f1f66f0383af9e3718aab5ea344b15821 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 14:26:05 -0700 Subject: [PATCH 15/43] Update test expected output --- .../bsc.bluetcl/commands/bpackage.tcl.bluetcl-out.expected | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/testsuite/bsc.bluetcl/commands/bpackage.tcl.bluetcl-out.expected b/testsuite/bsc.bluetcl/commands/bpackage.tcl.bluetcl-out.expected index 3d542c15f..d8b638257 100644 --- a/testsuite/bsc.bluetcl/commands/bpackage.tcl.bluetcl-out.expected +++ b/testsuite/bsc.bluetcl/commands/bpackage.tcl.bluetcl-out.expected @@ -55,9 +55,9 @@ PreludeBSV vMkCRegA5 PreludeBSV mkCReg PreludeBSV mkCRegU PreludeBSV mkCRegA -PreludeBSV _PreludeBSV.CReg5712 -PreludeBSV _PreludeBSV.CReg5808 -PreludeBSV _PreludeBSV.CReg5903 +PreludeBSV _PreludeBSV.CReg5714 +PreludeBSV _PreludeBSV.CReg5810 +PreludeBSV _PreludeBSV.CReg5905 Prelude Reg Prelude VReg Prelude vMkReg From d08c97a99d65f11109a53673e87483923c77e2b5 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 15:14:06 -0700 Subject: [PATCH 16/43] Update expected test output --- .../bsc.lib/CReg/TestCReg_TooBig.bsv.bsc-vcomp-out.expected | 4 ++-- .../bsc.lib/CReg/TestCReg_TooSmall.bsv.bsc-vcomp-out.expected | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/testsuite/bsc.lib/CReg/TestCReg_TooBig.bsv.bsc-vcomp-out.expected b/testsuite/bsc.lib/CReg/TestCReg_TooBig.bsv.bsc-vcomp-out.expected index af904a2a0..0ed61ea89 100644 --- a/testsuite/bsc.lib/CReg/TestCReg_TooBig.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.lib/CReg/TestCReg_TooBig.bsv.bsc-vcomp-out.expected @@ -1,9 +1,9 @@ checking package dependencies compiling TestCReg_TooBig.bsv code generation for sysTestCReg_TooBig starts -Error: "PreludeBSV.bsv", line 1001, column 37: (S0015) +Error: "PreludeBSV.bsv", line 1003, column 37: (S0015) Bluespec evaluation-time error: `mkCReg' cannot have more than five ports - During elaboration of `error' at "PreludeBSV.bsv", line 1001, column 13. + During elaboration of `error' at "PreludeBSV.bsv", line 1003, column 13. During elaboration of `rg' at "TestCReg_TooBig.bsv", line 5, column 19. During elaboration of `sysTestCReg_TooBig' at "TestCReg_TooBig.bsv", line 3, column 8. diff --git a/testsuite/bsc.lib/CReg/TestCReg_TooSmall.bsv.bsc-vcomp-out.expected b/testsuite/bsc.lib/CReg/TestCReg_TooSmall.bsv.bsc-vcomp-out.expected index 445d7a757..c846601a5 100644 --- a/testsuite/bsc.lib/CReg/TestCReg_TooSmall.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.lib/CReg/TestCReg_TooSmall.bsv.bsc-vcomp-out.expected @@ -1,10 +1,10 @@ checking package dependencies compiling TestCReg_TooSmall.bsv code generation for sysTestCReg_TooSmall starts -Error: "PreludeBSV.bsv", line 1002, column 37: (S0015) +Error: "PreludeBSV.bsv", line 1004, column 37: (S0015) Bluespec evaluation-time error: `mkCReg' cannot have a negative number of ports - During elaboration of `error' at "PreludeBSV.bsv", line 1002, column 13. + During elaboration of `error' at "PreludeBSV.bsv", line 1004, column 13. During elaboration of `rg' at "TestCReg_TooSmall.bsv", line 5, column 19. During elaboration of `sysTestCReg_TooSmall' at "TestCReg_TooSmall.bsv", line 3, column 8. From b651d364117508a44d69945372d5d1a938ebf4f3 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 19:36:41 -0700 Subject: [PATCH 17/43] Fix prefix computation in genwrap 'to' function and port saving statement construction --- src/comp/GenWrap.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 1b3774550..54a0f0868 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1072,17 +1072,18 @@ genTo pps ty mk = return tmpl where meth :: CExpr -> IfcPrefixes -> Id -> FInf -> GWMonad [CDefl] - meth sel prefixes ifcId (FInf f as r aIds) = + meth sel prefixes ifcIdIn (FInf f as r aIds) = do + ciPrags <- getInterfaceFieldPrags ifcIdIn f {- f should be qualifed -} mi <- chkInterface r case (mi, as) of - (Just (_, _, fts), []) -> do + (Just (ifcId, _, fts), []) -> do isAV <- isActionValue r if isAV then internalError "genTo 2: unexpected AV" else do --traceM ("selector: " ++ show sel) - newPrefixes <- extendPrefixes prefixes [] r f + newPrefixes <- extendPrefixes prefixes ciPrags r f meths <- mapM (meth (extSel sel f) newPrefixes ifcId) fts return (concat meths) _ -> do -- Generate the Verilog template for X @@ -1094,14 +1095,13 @@ genTo pps ty mk = let primselect = idPrimSelectFn noPosition let lit k = CLit $ num_to_cliteral_at noPosition k let selector n = cVApply primselect [posLiteral noPosition, extSel sel f, lit n] - elemPrefix <- extendPrefixes prefixes [] r f + elemPrefix <- extendPrefixes prefixes ciPrags r f let recurse num = do - numPrefix <- extendPrefixes elemPrefix [] r (mkNumId num) - meth (selector num) numPrefix ifcId (FInf idEmpty [] tVec []) + numPrefix <- extendPrefixes elemPrefix ciPrags r (mkNumId num) + meth (selector num) numPrefix ifcIdIn (FInf idEmpty [] tVec []) fields <- mapM recurse nums return (concat fields) _ -> do - ciPrags <- getInterfaceFieldPrags ifcId f let currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix localPrefix1 = fromMaybe (getIdBaseString f) (lookupPrefixIfcPragma ciPrags) localPrefix = joinStrings_ currentPre localPrefix1 @@ -2145,26 +2145,26 @@ saveTopModPortTypeStmt i t = -- saveFieldPortTypes v "prefix" ["arg1", "arg2"] "result" mkFieldSavePortTypeStmts :: Maybe CExpr -> Id -> [FInf] -> GWMonad [CStmt] -mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes +mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes ifcId where - meth :: IfcPrefixes -> FInf -> GWMonad [CStmt] - meth prefixes (FInf f as r aIds) = + meth :: IfcPrefixes -> Id -> FInf -> GWMonad [CStmt] + meth prefixes ifcIdIn (FInf f as r aIds) = do + ciPrags <- getInterfaceFieldPrags ifcIdIn f mi <- chkInterface r case (mi, as) of (Just (ti, _, fts), []) -> do - newprefixes <- extendPrefixes prefixes [] r f - concatMapM (meth newprefixes) fts + newprefixes <- extendPrefixes prefixes ciPrags r f + concatMapM (meth newprefixes ti) fts _ -> do isVec <- isVectorInterfaces r case (isVec, as) of (Just (n, tVec, isListN), []) -> do let nums = [0..(n-1)] :: [Integer] - let recurse num = do newprefixes <- extendPrefixes prefixes [] r f - meth newprefixes (FInf (mkNumId num) [] tVec []) + let recurse num = do newprefixes <- extendPrefixes prefixes ciPrags r f + meth newprefixes ifcIdIn (FInf (mkNumId num) [] tVec []) concatMapM recurse nums _ -> do - ciPrags <- getInterfaceFieldPrags ifcId f let methodStr = getIdBaseString f currentPre = ifcp_renamePrefixes prefixes -- the current rename prefix localPrefix1 = fromMaybe (getIdBaseString f) (lookupPrefixIfcPragma ciPrags) @@ -2174,7 +2174,7 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes Just str -> joinStrings_ currentPre str Nothing -> joinStrings_ currentPre methodStr - proxy = mkProxy $ foldr arrow r as + let proxy = mkProxy $ foldr arrow r as prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] result = stringLiteralAt noPosition resultName From 4020ade9c33ebf0e9a481dcfd49c1be32aabd3d4 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 19:36:58 -0700 Subject: [PATCH 18/43] Fix inadvertantly disabled type check for foreign functions --- src/comp/Parser/Classic/CParser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp/Parser/Classic/CParser.hs b/src/comp/Parser/Classic/CParser.hs index 78a4ad799..40e3ff3ae 100644 --- a/src/comp/Parser/Classic/CParser.hs +++ b/src/comp/Parser/Classic/CParser.hs @@ -406,7 +406,7 @@ pVarDefn = (pVarId +.+ dc ..+ pQType +.. dsm `into` \(var, typ) -> pClauses1 v pTyDefn :: Bool -> CParser CDefn pTyDefn b = l L_foreign ..+ pVarId +.+ dc ..+ pQType +.+ opt (eq ..+ pString) +.+ opt (cm ..+ lp ..+ many pString +.+ pForeignRes +.. rp) - >>>>> (\ i qt on ops -> Cforeign i qt on ops True) + >>>>> (\ i qt on ops -> Cforeign i qt on ops False) ||! l L_primitive ..+ pVarId +.+ dc ..+ pQType >>> Cprimitive -- ||! l L_primitive ..+ l L_class ..+ pPreds +.+ pTyConIdK +.+ many pTyVarId +.+ pFunDeps >>>>> CprimClass ||! l L_primitive ..+ l L_type ..+ pTyConId +.+ dc ..+ pKind >>- (\ (i, k) -> CprimType (IdKind i k)) From 2c9e86ec71c18804422f51ac44fe236f57212a75 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 15 Aug 2024 19:37:17 -0700 Subject: [PATCH 19/43] Update test expected results --- .../bsc.bugs/bluespec_inc/b1894/b1894.exp | 4 ++-- .../bluespec_inc/b292/mkDesign.v.expected | 22 +++++++++---------- .../ClockCheckCond.bsv.bsc-vcomp-out.expected | 2 +- .../Method.bsv.bsc-vcomp-out.expected | 2 +- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/testsuite/bsc.bugs/bluespec_inc/b1894/b1894.exp b/testsuite/bsc.bugs/bluespec_inc/b1894/b1894.exp index 547709a51..87690ae47 100644 --- a/testsuite/bsc.bugs/bluespec_inc/b1894/b1894.exp +++ b/testsuite/bsc.bugs/bluespec_inc/b1894/b1894.exp @@ -18,8 +18,8 @@ if { $ctest == 1 } { # backend, and only then if the user has specified that it's OK # for the Verilog and Bluesim backends to diverge). # - find_regexp mkTop.cxx {2047u \& \(\(\(\(\(tUInt32\)\(\(tUInt8\)0u\)\) << 3u\) \| \(\(\(tUInt32\)\(DEF_cond__h[0-9]+\)\) << 2u\)\) \| \(tUInt32\)\(DEF_v__h172\)\);} - find_regexp mkTop.cxx {DEF_v__h172 = DEF_AVMeth_s_m;} + find_regexp mkTop.cxx {2047u \& \(\(\(\(\(tUInt32\)\(\(tUInt8\)0u\)\) << 3u\) \| \(\(\(tUInt32\)\(DEF_cond__h[0-9]+\)\) << 2u\)\) \| \(tUInt32\)\(DEF_v__h\d+\)\);} + find_regexp mkTop.cxx {DEF_v__h\d+ = DEF_AVMeth_s_m;} } # Also test that BSC fully initializes DEF_AVMeth_s_m diff --git a/testsuite/bsc.bugs/bluespec_inc/b292/mkDesign.v.expected b/testsuite/bsc.bugs/bluespec_inc/b292/mkDesign.v.expected index 1528e3769..e167ddf36 100644 --- a/testsuite/bsc.bugs/bluespec_inc/b292/mkDesign.v.expected +++ b/testsuite/bsc.bugs/bluespec_inc/b292/mkDesign.v.expected @@ -86,8 +86,8 @@ module mkDesign(clk, wire i_multiplicand$EN; // remaining internal signals - wire [7 : 0] x__h508, x__h592, x__h741; - wire [3 : 0] x__h704, x__h778; + wire [7 : 0] x__h686, x__h780, x__h966; + wire [3 : 0] x__h1001, x__h930; // value method done assign done = i_done_reg ; @@ -99,7 +99,7 @@ module mkDesign(clk, assign i_acc$D_IN = (shift_and_add_load && i_count == 4'd0) ? 8'd0 : - (i_mult[0] ? x__h508 : i_acc) ; + (i_mult[0] ? x__h686 : i_acc) ; assign i_acc$EN = shift_and_add_load && i_count == 4'd0 || i_enable && i_count != 4'd4 ; @@ -108,7 +108,7 @@ module mkDesign(clk, assign i_count$D_IN = (shift_and_add_load && i_count == 4'd0) ? 4'd0 : - ((i_enable && i_count != 4'd4) ? x__h778 : 4'd0) ; + ((i_enable && i_count != 4'd4) ? x__h1001 : 4'd0) ; assign i_count$EN = 1'd1 ; // register i_done_reg @@ -127,24 +127,24 @@ module mkDesign(clk, assign i_mult$D_IN = (shift_and_add_load && i_count == 4'd0) ? shift_and_add_b : - x__h704 ; + x__h930 ; assign i_mult$EN = shift_and_add_load && i_count == 4'd0 || i_enable && i_count != 4'd4 ; // register i_multiplicand assign i_multiplicand$D_IN = - (shift_and_add_load && i_count == 4'd0) ? x__h592 : x__h741 ; + (shift_and_add_load && i_count == 4'd0) ? x__h780 : x__h966 ; assign i_multiplicand$EN = shift_and_add_load && i_count == 4'd0 || i_enable && i_count != 4'd4 ; // remaining internal signals - assign x__h508 = i_acc + i_multiplicand ; - assign x__h592 = { 4'b0, shift_and_add_a } ; - assign x__h704 = { 1'd0, i_mult[3:1] } ; - assign x__h741 = { i_multiplicand[6:0], 1'd0 } ; - assign x__h778 = i_count + 4'd1 ; + assign x__h1001 = i_count + 4'd1 ; + assign x__h686 = i_acc + i_multiplicand ; + assign x__h780 = { 4'b0, shift_and_add_a } ; + assign x__h930 = { 1'd0, i_mult[3:1] } ; + assign x__h966 = { i_multiplicand[6:0], 1'd0 } ; // handling of inlined registers diff --git a/testsuite/bsc.mcd/Misc/ClockCheckCond.bsv.bsc-vcomp-out.expected b/testsuite/bsc.mcd/Misc/ClockCheckCond.bsv.bsc-vcomp-out.expected index 658bd9d0d..1c793d355 100644 --- a/testsuite/bsc.mcd/Misc/ClockCheckCond.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.mcd/Misc/ClockCheckCond.bsv.bsc-vcomp-out.expected @@ -6,7 +6,7 @@ Error: "ClockCheckCond.bsv", line 6, column 8: (G0007) Method calls by clock domain: Clock domain 1: default_clock: - the_y.read at "ClockCheckCond.bsv", line 2, column 18, + the_y.read at "ClockCheckCond.bsv", line 2, column 10, Clock domain 2: c: the_x.read at "ClockCheckCond.bsv", line 14, column 19, diff --git a/testsuite/bsc.names/signal_names/Method.bsv.bsc-vcomp-out.expected b/testsuite/bsc.names/signal_names/Method.bsv.bsc-vcomp-out.expected index dfedb8053..63941bd60 100644 --- a/testsuite/bsc.names/signal_names/Method.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.names/signal_names/Method.bsv.bsc-vcomp-out.expected @@ -17,7 +17,7 @@ arg info [clockarg default_clock;, resetarg default_reset;] -- APackage resets [(0, { wire: RST_N })] -- AP state elements -rg :: ABSTRACT: PreludeBSV._PreludeBSV.VRWire109 = RWire +rg :: ABSTRACT: PreludeBSV._PreludeBSV.VRWire111 = RWire (VModInfo RWire clock clk(); From 0c15378de1a6ab4107e1a967b38dce9589576b48 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 18:45:21 -0700 Subject: [PATCH 20/43] Add interface port name sanity checking after elaboration --- src/comp/GenWrap.hs | 6 +- src/comp/IExpand.hs | 4 + src/comp/IExpandUtils.hs | 86 +++++++++- src/comp/IfcBetterInfo.hs | 3 - src/comp/PragmaCheck.hs | 148 +----------------- src/comp/VModInfo.hs | 2 +- .../conflicts/clock/ClockEnable.bsv | 2 + .../conflicts/clock/ClockResult.bsv | 2 + .../conflicts/clock/GateEnable.bsv | 2 + .../conflicts/modarg/ModargClock.bsv | 1 + .../conflicts/modarg/ModargGate.bsv | 1 + .../conflicts/modarg/ModargReset.bsv | 1 + .../conflicts/modparam/ModparamClock.bsv | 1 + .../conflicts/modparam/ModparamGate.bsv | 1 + .../conflicts/modparam/ModparamReset.bsv | 1 + 15 files changed, 110 insertions(+), 151 deletions(-) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 54a0f0868..db57583e6 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1324,11 +1324,7 @@ mkNewModDef genIfcMap (def@(CDef i (CQType _ t) dcls), cqt, vtis, vps) = ftps <- mapM collectIfcInfo (reverse cfields) -- get back the arg port to type mapping, for recording flgs <- getFlags - -- XXX Need to sanity check port names after elaboration. - -- arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps - let arg_pts = - [ (pid,pt) | (pid,pt,Simple {}) <- vtis, not $ isParamModArg vps pid || pt == tClock && pt == tReset ] ++ - [ (pid,pt) | (_,_,Vector _ _ _ ais) <- vtis, (pid,pt) <- concatMap extractVTPairs ais ] + arg_pts <- convEM $ checkModulePortNames flgs (getPosition i) vps vtis ftps let arg_infos = thd $ unzip3 vtis (vs, ts) = unzip $ concatMap extractVTPairs arg_infos diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index f77bfb4d4..1b5c32e37 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -247,6 +247,10 @@ iExpand errh flags symt alldefs is_noinlined_func pps def@(IDef mi _ _ _) = do let (iks, args, varginfo, ifc) = goutput go let rules = go_rules go let insts = go_state_vars go + let vclockinfo = go_vclockinfo go + let vresetinfo = go_vresetinfo go + + chkIfcPortNames errh args ifc vclockinfo vresetinfo -- turn heap into IDef definitions let diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index d2e99be34..947eb4899 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -35,7 +35,7 @@ module IExpandUtils( addGateUsesToInhigh, addGateInhighAttributes, chkClkArgGateWires, chkClkAncestry, chkClkSiblings, getInputResetClockDomain, setInputResetClockDomain, - chkInputClockPragmas, + chkInputClockPragmas, chkIfcPortNames, getBoundaryClock, getBoundaryClocks, boundaryClockToName, getBoundaryReset, getBoundaryResets, boundaryResetToName, getInputResets, makeInputClk, makeInputRstn, makeOutputClk, makeOutputRstn, @@ -102,6 +102,7 @@ import IWireSet import Pragma(PProp(..), SPIdMap, substSchedPragmaIds, extractSchedPragmaIds, removeSchedPragmaIds) import Util +import Verilog(vKeywords, vIsValidIdent) import IOUtil(progArgs) import ISyntaxXRef(mapIExprPosition, mapIExprPosition2) @@ -2010,6 +2011,89 @@ chkClkAncestry modName instName pos ancestors clockargnum_map = when (not (null err_pairs)) $ errG (pos, EClockArgAncestors modName instName err_pairs) +chkIfcPortNames :: ErrorHandle -> [IAbstractInput] -> [HEFace] -> VClockInfo -> VResetInfo -> IO () +chkIfcPortNames errh args ifcs (ClockInfo ci co _ _) (ResetInfo ri ro) = + when (not (null emsgs)) $ bsError errh emsgs + where + input_clock_ports i = + case lookup i ci of + Just (Just (VName o, Right (VName g))) -> [o, g] + Just (Just (VName o, Left _)) -> [o] + _ -> [] + output_clock_ports i = + case lookup i co of + Just (Just (VName o, Just (VName g, _))) -> [o, g] + Just (Just (VName o, Nothing)) -> [o] + _ -> [] + input_reset_ports i = + case lookup i ri of + Just (Just (VName r), _) -> [r] + _ -> [] + output_reset_ports i = + case lookup i ro of + Just (Just (VName r), _) -> [r] + _ -> [] + + arg_port_names = [ (getIdBaseString i, i) | IAI_Port (i, _) <- args ] + arg_inout_names = [ (getIdBaseString i, i) | IAI_Inout i _ <- args ] + arg_clock_names = [ (n, i) | IAI_Clock i _ <- args, n <- input_clock_ports i ] + arg_reset_names = [ (n, i) | IAI_Reset i <- args, n <- input_reset_ports i ] + arg_names = sort $ arg_port_names ++ arg_inout_names ++ arg_clock_names ++ arg_reset_names + + ifc_port_names = + [ (n, i) + | IEFace {ief_fieldinfo = Method i _ _ _ ins out en} <- ifcs, + (VName n, _) <- ins ++ maybeToList out ++ maybeToList en ] + ifc_inout_names = + [ (n, i) | IEFace {ief_fieldinfo = Inout i (VName n) _ _} <- ifcs ] + ifc_clock_names = + [ (n, i) | IEFace {ief_fieldinfo = Clock i} <- ifcs, n <- output_clock_ports i ] + ifc_reset_names = + [ (n, i) | IEFace {ief_fieldinfo = Reset i} <- ifcs, n <- output_reset_ports i ] + ifc_names = sort $ ifc_port_names ++ ifc_inout_names ++ ifc_clock_names ++ ifc_reset_names + + -- --------------- + -- check that no ifc port name clashes with another port name and + -- check that no ifc port name clashes with a Verilog keyword and + -- check that each ifc port name is a valid Verilog identifier + ifc_same_name = filter (\xs -> (length xs) > 1) $ + groupBy (\(n1,_) (n2,_) -> n1 == n2) ifc_names + ifc_kw_clash = filter (\(n,_) -> n `elem` vKeywords) ifc_names + ifc_bad_ident = filter (\(n,_) -> not (vIsValidIdent n)) ifc_names + emsgs0 = let mkErr xs = + let ns = [(n, getPosition i, getIdBaseString i) + | (n,i) <- xs ] + in case ns of + ((v,p1,m1):(_,p2,m2):_) -> + (p1, EPortNamesClashFromMethod m1 m2 v p2) + _ -> internalError ("emsg0: impossible") + in map mkErr ifc_same_name + emsgs1 = let mkErr (n,i) = (getPosition i, + EPortKeywordClashFromMethod + (getIdBaseString i) n) + in map mkErr ifc_kw_clash + emsgs2 = let mkErr (n,i) = (getPosition i, + EPortNotValidIdentFromMethod + (getIdBaseString i) n) + in map mkErr ifc_bad_ident + + -- --------------- + -- check that no arg port clashes with an ifc port + ifc_ports_map = M.fromList ifc_names + + findIfcPortName (p, a) = + case M.lookup p ifc_ports_map of + Nothing -> Nothing + Just m -> Just (p, m, a) + + arg_ifc_dups = catMaybes $ map findIfcPortName arg_names + emsgs3 = let mkErr (p,m,a) = (getPosition a, + EPortNamesClashArgAndIfc + p (getIdBaseString a) (getIdBaseString m) (getPosition m)) + in map mkErr arg_ifc_dups + + emsgs = emsgs0 ++ emsgs1 ++ emsgs2 ++ emsgs3 + -- --------------- {-# INLINE newStateNo #-} diff --git a/src/comp/IfcBetterInfo.hs b/src/comp/IfcBetterInfo.hs index 103bf4082..8baded88b 100644 --- a/src/comp/IfcBetterInfo.hs +++ b/src/comp/IfcBetterInfo.hs @@ -17,9 +17,6 @@ import Pragma import PPrint import IdPrint import VModInfo -import FStringCompat(mkFString) -import ISyntax -import IConv(iConvT) -- import Util(traces) diff --git a/src/comp/PragmaCheck.hs b/src/comp/PragmaCheck.hs index 56fdeff33..d8c5a30c3 100644 --- a/src/comp/PragmaCheck.hs +++ b/src/comp/PragmaCheck.hs @@ -11,17 +11,15 @@ import Control.Monad(msum) import Data.List(groupBy, sort, partition, nub, intersect) import Data.Maybe(listToMaybe, mapMaybe, catMaybes, fromMaybe) -import Util(thd, fst3, headOrErr, fromJustOrErr) +import Util(thd, fst3, headOrErr) import Verilog(vKeywords, vIsValidIdent) -import Error(internalError, EMsg, ErrMsg(..)) +import Error(EMsg, ErrMsg(..)) import ErrorMonad(ErrorMonad(..)) -import PFPrint import Position import Id -import PreIds(idDefaultClock, idDefaultReset, idCLK, idCLK_GATE, - idPrimAction, idActionValue_, mk_no) +import PreIds(idDefaultClock, idDefaultReset, idCLK, idCLK_GATE, mk_no) import FStringCompat import PreStrings(fsUnderscore) @@ -29,7 +27,7 @@ import Flags(Flags(..)) import Pragma import CType -import Type(tClock, tReset, tInout_) +import Type(tClock, tReset) -- ============================== @@ -559,85 +557,9 @@ checkModulePortNames flgs pos pps vtis ftps = isClkField (_,t,_) = t == tClock isRstField (_,t,_) = t == tReset - isInoutField (_,t,_) = case t of - (TAp tt _) | (tt == tInout_) -> True - _ -> False - - getMString :: Maybe String -> String - getMString (Just str) = str - getMString Nothing = internalError ("getMString: empty field") - + (clk_fs, other_fs) = partition isClkField ftps - (rst_fs, other_fs') = partition isRstField other_fs - (iot_fs, method_fs) = partition isInoutField other_fs' - - ifc_clock_ports = - let mkClockPorts (i,_,ps) = - let mpref = getClockPragmaInfo ps - -- convert to Id and back, to reuse "mkPortName" - pref_id = mk_homeless_id $ getMString $ mpref - osc = mkPortName idCLK osc_prefix Nothing pref_id - gate = mkPortName idCLK_GATE gate_prefix Nothing pref_id - in [(getIdBaseString osc, i), - (getIdBaseString gate, i)] - in concatMap mkClockPorts clk_fs - - ifc_reset_ports = - let mkResetPort (i,_,ps) = - let mpref = getResetPragmaInfo ps - -- convert to Id and back, to reuse "mkPortName" - pref_id = mk_homeless_id $ getMString $ mpref - p = mkPortName idrstn rst_prefix Nothing pref_id - in (getIdBaseString p, i) - in map mkResetPort rst_fs - - ifc_inout_ports = - let mkInoutPort (i,t,ps) = - let pref = getMString $ getInoutPragmaInfo ps - in (pref, i) - in map mkInoutPort iot_fs - - ifc_method_ports = - let mkMethodPorts (i,t,ps) = - let resType = getRes t - resTypeId = fromJustOrErr - ("ifc_method_ports: " ++ ppReadable t) - (leftCon resType) - -- XXX can PrimAction ever occur? - -- XXX (Maybe if explicitly written?) - -- The types Action and ActionValue (which should be the - -- only types written by the user) become ActionValue_ - -- in the flattened interface (with Action being size 0). - -- So ActionValue_ should be only type seen. - isPA = (qualEq resTypeId idPrimAction) - isAV = (qualEq resTypeId idActionValue_) - -- If the user wrote "Action" the flattened ifc is - -- ActionValue_#(0). If the user wrote ActionValue#(t) - -- then the flattened ifc is ActionValue#(sz), where - -- "sz" is a variable reference in context Bits#(t,sz). - -- If GenWrap did ctxReduce, then these variables would - -- go away (if not, then we'd error, as iExpand does - -- now). In the meantime, just look for explicit 0. - isAV0 = case resType of - (TAp (TCon (TyCon av _ _)) (TCon (TyNum n _))) - | qualEq av idActionValue_ -> (n == 0) - _ -> False - (mpref, mres, mrdy, men, argids, ar, ae) = - getMethodPragmaInfo ps - res = if (isPA || isAV0) then [] else [getMString mres] - rdy = if (ar) then [] else [getMString mrdy] - en = if (not ae) && (isAV || isPA) - then [getMString men] else [] - argToName :: String -> Id -> String - argToName pstr aid = joinStrings_ pstr (getIdString aid) - args = map (argToName (getMString mpref)) argids - in - if (isRdyId i) then [] - else zip (res ++ rdy ++ en ++ args) (repeat i) - in concatMap mkMethodPorts method_fs - - all_ifc_info = ifc_clock_ports ++ ifc_reset_ports ++ - ifc_inout_ports ++ ifc_method_ports + (rst_fs, _) = partition isRstField other_fs -- --------------- -- check that no arg port name clashes with another port name and @@ -663,52 +585,6 @@ checkModulePortNames flgs pos pps vtis ftps = emsgs2 = let mkErr (n,i) = (getPosition i, EPortNotValidIdent n) in map mkErr arg_bad_ident - -- --------------- - -- check that no ifc port name clashes with another port name and - -- check that no ifc port name clashes with a Verilog keyword and - -- check that each ifc port name is a valid Verilog identifier - - ifc_names = sort all_ifc_info - ifc_same_name = filter (\xs -> (length xs) > 1) $ - groupBy (\(n1,_) (n2,_) -> n1 == n2) ifc_names - ifc_kw_clash = filter (\(n,_) -> n `elem` vKeywords) ifc_names - ifc_bad_ident = filter (\(n,_) -> not (vIsValidIdent n)) ifc_names - emsgs3 = let mkErr xs = - let ns = [(n, getPosition i, getIdBaseString i) - | (n,i) <- xs ] - in case ns of - ((v,p1,m1):(_,p2,m2):_) -> - (p1, EPortNamesClashFromMethod m1 m2 v p2) - _ -> internalError ("emsg3: impossible") - in map mkErr ifc_same_name - emsgs4 = let mkErr (n,i) = (getPosition i, - EPortKeywordClashFromMethod - (getIdBaseString i) n) - in map mkErr ifc_kw_clash - emsgs5 = let mkErr (n,i) = (getPosition i, - EPortNotValidIdentFromMethod - (getIdBaseString i) n) - in map mkErr ifc_bad_ident - - -- --------------- - -- check that no arg port clashes with an ifc port - - - ifc_ports_map = M.fromList ifc_names - - findIfcPortName api@(API { api_port = Just p }) = - case (M.lookup (getIdBaseString p) ifc_ports_map) of - Nothing -> Nothing - Just m -> Just (p, m, getAPIArgName api) - findIfcPortName (API { api_port = Nothing }) = Nothing - - arg_ifc_dups = catMaybes $ map findIfcPortName all_arg_info - emsgs6 = let mkErr (p,m,a) = (pos, - EPortNamesClashArgAndIfc - (pfpString p) (pfpString a) - (pfpString m) (getPosition m)) - in map mkErr arg_ifc_dups - -- --------------- -- warn if a prefix is supplied but never used @@ -755,8 +631,7 @@ checkModulePortNames flgs pos pps vtis ftps = -- report any errors or warnings -- report all errors, since none trump any others - emsgs = emsgs0 ++ emsgs1 ++ emsgs2 ++ emsgs3 ++ - emsgs4 ++ emsgs5 ++ emsgs6 + emsgs = emsgs0 ++ emsgs1 ++ emsgs2 wmsgs = wmsgs0 ++ wmsgs1 @@ -768,12 +643,3 @@ checkModulePortNames flgs pos pps vtis ftps = -- ============================== - --- XXX copied from GenWrap --- Join string together with an underscore if either is not empty. -joinStrings_ :: String -> String -> String -joinStrings_ "" s2 = s2 -joinStrings_ s1 "" = s1 -joinStrings_ s1 s2 = s1 ++ "_" ++ s2 - --- ============================== diff --git a/src/comp/VModInfo.hs b/src/comp/VModInfo.hs index cf6f5ac39..085732eec 100644 --- a/src/comp/VModInfo.hs +++ b/src/comp/VModInfo.hs @@ -67,7 +67,7 @@ getVNameString (VName string) = string -- convert Bluespec identifier to Verilog names id_to_vName :: Id -> VName -id_to_vName i = VName (getIdString i) +id_to_vName i = VName (getIdBaseString i) vName_to_id :: VName -> Id vName_to_id (VName s) = mk_homeless_id s diff --git a/testsuite/bsc.names/portRenaming/conflicts/clock/ClockEnable.bsv b/testsuite/bsc.names/portRenaming/conflicts/clock/ClockEnable.bsv index dfc572448..6c5abb46d 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/clock/ClockEnable.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/clock/ClockEnable.bsv @@ -6,4 +6,6 @@ endinterface (* synthesize *) module mkClockEnable(Ifc); + method m = noAction; + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/clock/ClockResult.bsv b/testsuite/bsc.names/portRenaming/conflicts/clock/ClockResult.bsv index 937f80ea5..177411a5f 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/clock/ClockResult.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/clock/ClockResult.bsv @@ -6,4 +6,6 @@ endinterface (* synthesize *) module mkClockResult(Ifc); + method m = False; + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/clock/GateEnable.bsv b/testsuite/bsc.names/portRenaming/conflicts/clock/GateEnable.bsv index 37fcea71c..65ec4ea47 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/clock/GateEnable.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/clock/GateEnable.bsv @@ -6,4 +6,6 @@ endinterface (* synthesize *) module mkGateEnable(Ifc); + method m = noAction; + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargClock.bsv b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargClock.bsv index f397463f6..4e4d628c2 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargClock.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargClock.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModargClock ((*port="CLK_c"*)int c, Ifc i); + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargGate.bsv b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargGate.bsv index 0ba6c94c3..01d9aecd3 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargGate.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargGate.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModargGate ((*port="CLK_GATE_c"*)int c, Ifc i); + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargReset.bsv b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargReset.bsv index f3bc6d5d5..4677891de 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargReset.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modarg/ModargReset.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModargReset ((*port="RST_N_r"*)int r, Ifc i); + method r = noReset; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamClock.bsv b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamClock.bsv index c8e73a159..505b46068 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamClock.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamClock.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModparamClock #((*parameter="CLK_c"*)parameter int c) (Ifc); + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamGate.bsv b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamGate.bsv index 561a4829e..18ae8dc52 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamGate.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamGate.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModparamGate #((*parameter="CLK_GATE_c"*)parameter int c) (Ifc); + method c = noClock; endmodule diff --git a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamReset.bsv b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamReset.bsv index 5585103c3..7a4e7938c 100644 --- a/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamReset.bsv +++ b/testsuite/bsc.names/portRenaming/conflicts/modparam/ModparamReset.bsv @@ -4,5 +4,6 @@ endinterface (* synthesize *) module mkModparamReset #((*parameter="RST_N_r"*)parameter int r) (Ifc); + method r = noReset; endmodule From 1ecce93cf8300202a82ee5aa53ffc5fe969b8c3b Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 19:05:04 -0700 Subject: [PATCH 21/43] Fix bug introduced in computing split vector interface prefixes --- src/comp/GenWrap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index db57583e6..4bf399cc0 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -1097,7 +1097,7 @@ genTo pps ty mk = let selector n = cVApply primselect [posLiteral noPosition, extSel sel f, lit n] elemPrefix <- extendPrefixes prefixes ciPrags r f let recurse num = do - numPrefix <- extendPrefixes elemPrefix ciPrags r (mkNumId num) + numPrefix <- extendPrefixes elemPrefix [] r (mkNumId num) meth (selector num) numPrefix ifcIdIn (FInf idEmpty [] tVec []) fields <- mapM recurse nums return (concat fields) From 936d1402ce460511e57065bbf0ec4ee6c587688b Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 19:34:25 -0700 Subject: [PATCH 22/43] Add sketch of splitting tuples --- src/Libraries/Base1/Prelude.bs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index cb0afbbeb..2d9f855f1 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4602,11 +4602,40 @@ instance SplitPorts () () where unsplitPorts = id portNames _ _ = Nil +-- Default instance: don't split anything we don't know how to split. instance SplitPorts a (Port a) where splitPorts = Port unsplitPorts (Port a) = a portNames _ base = Cons base Nil +{- +XXX Consider if we want to split tuples by default. This would change the current behavior, +but might be a sensible one, especially if we support methods with multiple output ports. + +instance (SplitTuplePorts (a, b) r) => SplitPorts (a, b) r where + splitPorts = splitTuplePorts + unsplitPorts = unsplitTuplePorts + portNames = splitTuplePortNames 1 + +class SplitTuplePorts a p | a -> p where + splitTuplePorts :: a -> p + unsplitTuplePorts :: p -> a + splitTuplePortNames :: Integer -> a -> String -> List String + +instance (SplitPorts a p, SplitTuplePorts b q, AppendTuple p q r) => SplitTuplePorts (a, b) r where + splitTuplePorts (a, b) = splitPorts a `appendTuple` splitTuplePorts b + unsplitTuplePorts x = case splitTuple x of + (a, b) -> (unsplitPorts a, unsplitTuplePorts b) + splitTuplePortNames i _ base = + portNames (_ :: a) (base +++ "_" +++ integerToString i) `listPrimAppend` + splitTuplePortNames (i + 1) (_ :: b) base + +instance (SplitPorts a p) => SplitTuplePorts a p where + splitTuplePorts = splitPorts + unsplitTuplePorts x = unsplitPorts x + splitTuplePortNames i _ base = portNames (_ :: a) $ base +++ "_" +++ integerToString i +-} + -- Newtype tag to indicate that a type should be recursively split into ports data DeepSplit a = DeepSplit a From eccaf0386d5b347f55aea42a0d4e2d420273495d Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 19:49:00 -0700 Subject: [PATCH 23/43] Check for clash with default clock/reset ports --- src/comp/IExpandUtils.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index 947eb4899..53de081f7 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -2038,7 +2038,13 @@ chkIfcPortNames errh args ifcs (ClockInfo ci co _ _) (ResetInfo ri ro) = arg_inout_names = [ (getIdBaseString i, i) | IAI_Inout i _ <- args ] arg_clock_names = [ (n, i) | IAI_Clock i _ <- args, n <- input_clock_ports i ] arg_reset_names = [ (n, i) | IAI_Reset i <- args, n <- input_reset_ports i ] - arg_names = sort $ arg_port_names ++ arg_inout_names ++ arg_clock_names ++ arg_reset_names + + default_clock_names = [ (n, idDefaultClock) | n <- input_clock_ports idDefaultClock ] + default_reset_names = [ (n, idDefaultReset) | n <- input_reset_ports idDefaultReset ] + + arg_names = sort $ + arg_port_names ++ arg_inout_names ++ arg_clock_names ++ arg_reset_names ++ + default_clock_names ++ default_reset_names ifc_port_names = [ (n, i) From 4e48c17e21d02767adae0adb83e2f8ae233a40ce Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 20:15:15 -0700 Subject: [PATCH 24/43] Better error message for synthesizing an interface with a non-Bits method --- src/comp/ContextErrors.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/comp/ContextErrors.hs b/src/comp/ContextErrors.hs index 93fad5883..63e5cc555 100644 --- a/src/comp/ContextErrors.hs +++ b/src/comp/ContextErrors.hs @@ -165,6 +165,11 @@ handleContextReduction' pos _ -> return $ defaultContextReductionErr pos p _ -> internalError("handleContextReduction': " ++ "SizedLiteral instance contains wrong number of types") + | cid == idWrapField = + case ts of + [t, _] -> return $ handleCtxRedWrapField pos p t + _ -> internalError("handleContextReduction': " ++ + "WrapField instance contains wrong number of types") -- | cid == idLiteral = -- | cid == idRealLiteral = @@ -454,6 +459,13 @@ handleCtxRedPrimPort pos (vp, reduced_ps) userty = in (pos, ECtxErrPrimPort (pfpString userty) poss hasVar) +-- -------------------- + +handleCtxRedWrapField:: Position -> (VPred, [VPred]) -> Type -> EMsg +handleCtxRedWrapField pos (vp, reduced_ps) userty = + (pos, EBadIfcType (pfpString userty) -- XXX reporting the type, no easy way to get the method name here. + "This method uses types that are not in the Bits or SplitPorts typeclass.") + -- ======================================================================== -- Weak Context From 14fb02c1896a45e03cbdd5027a0ae52e848151b7 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 20:17:48 -0700 Subject: [PATCH 25/43] Cleanup trailing whitespace --- src/Libraries/Base1/Prelude.bs | 6 +++--- src/comp/GenWrap.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 2d9f855f1..2c4da1d16 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4454,7 +4454,7 @@ instance (WrapMethod m w) => (WrapField m w) where let baseNames = methodArgBaseNames (_ :: m) prefix names 1 in primMethod (inputPortNames (_ :: m) baseNames) ∘ toWrapMethod fromWrapField = fromWrapMethod - saveFieldPortTypes _ modName prefix names = + saveFieldPortTypes _ modName prefix names = let baseNames = methodArgBaseNames (_ :: m) prefix names 1 in saveMethodPortTypes (_ :: m) modName baseNames @@ -4575,7 +4575,7 @@ instance WrapPorts () () where checkPortNames :: (SplitPorts a p, TupleSize p n) => a -> String -> List String checkPortNames proxy base = let pn = portNames proxy base - in + in if listLength pn /= valueOf n then error $ "SplitPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++ " ports, but " +++ integerToString (listLength pn) +++ " port names were given" @@ -4669,7 +4669,7 @@ instance (SplitPorts a p) => DeepSplitPorts' r a p where instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where deepSplitPorts' _ = deepSplitPorts'' ∘ from - deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' + deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: r) class DeepSplitPorts'' r p | r -> p where diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 4bf399cc0..374acd5bc 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -2142,7 +2142,7 @@ saveTopModPortTypeStmt i t = -- saveFieldPortTypes v "prefix" ["arg1", "arg2"] "result" mkFieldSavePortTypeStmts :: Maybe CExpr -> Id -> [FInf] -> GWMonad [CStmt] mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes ifcId - where + where meth :: IfcPrefixes -> Id -> FInf -> GWMonad [CStmt] meth prefixes ifcIdIn (FInf f as r aIds) = do From 7aea56f5a48934a806834c06ea6ae6c7399b8e4b Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 20:31:05 -0700 Subject: [PATCH 26/43] Update expected results, testsuite passing --- .../NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected | 10 +++------- .../NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected | 9 +++------ 2 files changed, 6 insertions(+), 13 deletions(-) diff --git a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected index 727783b2d..6e1dd0aba 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected @@ -6,10 +6,6 @@ Error: Unknown position: (T0031) Bits#(NoInline_ArgNotInBits::L, a__) The proviso was implied by expressions at the following positions: "NoInline_ArgNotInBits.bsv", line 4, column 15 -Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0032) - This expression requires the following proviso which could not be resolved: - WrapField#(function Bool f(NoInline_ArgNotInBits::L x1), a__) - An instance for this proviso exists, but it depends on the following - provisos for which there are no instances: - Curry#(function Bit#(1) f(Bit#(b__) x1), a__), - Bits#(NoInline_ArgNotInBits::L, b__) +Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0043) + Cannot synthesize `function Bool f(NoInline_ArgNotInBits::L x1)': This + method uses types that are not in the Bits or SplitPorts typeclass. diff --git a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected index 75030a887..be21fcb36 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected @@ -6,12 +6,9 @@ Error: Unknown position: (T0031) Bits#(NoInline_ResNotInBits::L, a__) The proviso was implied by expressions at the following positions: "NoInline_ResNotInBits.bsv", line 4, column 12 -Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0032) - This expression requires the following proviso which could not be resolved: - WrapField#(function NoInline_ResNotInBits::L f(Bool x1), a__) - An instance for this proviso exists, but it depends on the following proviso - for which there is no instance: - Bits#(NoInline_ResNotInBits::L, b__) +Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0043) + Cannot synthesize `function NoInline_ResNotInBits::L f(Bool x1)': This + method uses types that are not in the Bits or SplitPorts typeclass. Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0029) Signature mismatch (given too general): given: From af1e1eb7935d982a8c7f6fe811ea5466d692c215 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 16 Aug 2024 21:03:55 -0700 Subject: [PATCH 27/43] Reorganize port splitting utilites into a seperate library, add ShallowSplitPorts --- src/Libraries/Base1/Prelude.bs | 74 +----------- src/Libraries/Base1/SplitPorts.bs | 190 ++++++++++++++++++++++++++++++ src/Libraries/Base1/Vector.bs | 14 --- src/Libraries/Base1/depends.mk | 3 +- 4 files changed, 193 insertions(+), 88 deletions(-) create mode 100644 src/Libraries/Base1/SplitPorts.bs diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 2c4da1d16..464bde00a 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -257,8 +257,7 @@ package Prelude( MetaConsNamed(..), MetaConsAnon(..), MetaField(..), primMethod, WrapField(..), WrapMethod(..), WrapPorts(..), - Port(..), SplitPorts(..), - DeepSplit(..), DeepSplitPorts(..), DeepSplitPorts'(..), DeepSplitPorts''(..) + Port(..), SplitPorts(..) ) where infixr 0 $ @@ -4635,74 +4634,3 @@ instance (SplitPorts a p) => SplitTuplePorts a p where unsplitTuplePorts x = unsplitPorts x splitTuplePortNames i _ base = portNames (_ :: a) $ base +++ "_" +++ integerToString i -} - --- Newtype tag to indicate that a type should be recursively split into ports -data DeepSplit a = DeepSplit a - -instance (DeepSplitPorts a p) => SplitPorts (DeepSplit a) p where - splitPorts (DeepSplit x) = deepSplitPorts x - unsplitPorts = DeepSplit ∘ deepUnsplitPorts - portNames _ = deepSplitPortNames (_ :: a) - - --- Helper class using generics, to recursively split structs and vectors into a tuple of ports. -class DeepSplitPorts a p | a -> p where - deepSplitPorts :: a -> p - deepUnsplitPorts :: p -> a - deepSplitPortNames :: a -> String -> List String - -instance (Generic a r, DeepSplitPorts' r a p) => - DeepSplitPorts a p where - deepSplitPorts = deepSplitPorts' (_ :: r) - deepUnsplitPorts = deepUnsplitPorts' (_ :: r) - deepSplitPortNames = deepSplitPortNames' (_ :: r) - -class DeepSplitPorts' r a p | r a -> p where - deepSplitPorts' :: r -> a -> p - deepUnsplitPorts' :: r -> p -> a - deepSplitPortNames' :: r -> a -> String -> List String - -instance (SplitPorts a p) => DeepSplitPorts' r a p where - deepSplitPorts' _ = splitPorts - deepUnsplitPorts' _ = unsplitPorts - deepSplitPortNames' _ = portNames - -instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where - deepSplitPorts' _ = deepSplitPorts'' ∘ from - deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' - deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: r) - -class DeepSplitPorts'' r p | r -> p where - deepSplitPorts'' :: r -> p - deepUnsplitPorts'' :: p -> r - deepSplitPortNames'' :: r -> String -> List String - -instance (DeepSplitPorts'' a p, DeepSplitPorts'' b q, AppendTuple p q r) => DeepSplitPorts'' (a, b) r where - deepSplitPorts'' (a, b) = deepSplitPorts'' a `appendTuple` deepSplitPorts'' b - deepUnsplitPorts'' x = case splitTuple x of - (a, b) -> (deepUnsplitPorts'' a, deepUnsplitPorts'' b) - deepSplitPortNames'' _ base = - deepSplitPortNames'' (_ :: a) base `listPrimAppend` deepSplitPortNames'' (_ :: b) base - -instance DeepSplitPorts'' () () where - deepSplitPorts'' _ = () - deepUnsplitPorts'' _ = () - deepSplitPortNames'' _ _ = Nil - -instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta (MetaField name idx) r) p where - deepSplitPorts'' (Meta x) = deepSplitPorts'' x - deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' - deepSplitPortNames'' _ base = deepSplitPortNames'' (_ :: r) $ - if stringHead (stringOf name) == '_' - then base +++ stringOf name - else base +++ "_" +++ stringOf name - -instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta m r) p where - deepSplitPorts'' (Meta x) = deepSplitPorts'' x - deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' - deepSplitPortNames'' _ = deepSplitPortNames'' (_ :: r) - -instance (DeepSplitPorts a p) => DeepSplitPorts'' (Conc a) p where - deepSplitPorts'' (Conc x) = deepSplitPorts x - deepUnsplitPorts'' = Conc ∘ deepUnsplitPorts - deepSplitPortNames'' _ = deepSplitPortNames (_ :: a) diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs new file mode 100644 index 000000000..708c65b30 --- /dev/null +++ b/src/Libraries/Base1/SplitPorts.bs @@ -0,0 +1,190 @@ +package SplitPorts where + +-- Utilities for port splitting + +import qualified List +import Vector + + + +-- Newtype tags to indicate that a types should be split (recursively or not) into ports +data ShallowSplit a = ShallowSplit a +data DeepSplit a = DeepSplit a + +instance (ShallowSplitPorts a p) => SplitPorts (ShallowSplit a) p where + splitPorts (ShallowSplit x) = shallowSplitPorts x + unsplitPorts = ShallowSplit ∘ shallowUnsplitPorts + portNames _ = shallowSplitPortNames (_ :: a) + +instance (DeepSplitPorts a p) => SplitPorts (DeepSplit a) p where + splitPorts (DeepSplit x) = deepSplitPorts x + unsplitPorts = DeepSplit ∘ deepUnsplitPorts + portNames _ = deepSplitPortNames (_ :: a) + + +-- Helper class using generics, to split a struct or vector into a tuple of ports. +class ShallowSplitPorts a p | a -> p where + shallowSplitPorts :: a -> p + shallowUnsplitPorts :: p -> a + shallowSplitPortNames :: a -> String -> List String + +instance (Generic a r, ShallowSplitPorts' r p) => + ShallowSplitPorts a p where + shallowSplitPorts = shallowSplitPorts' ∘ from + shallowUnsplitPorts = to ∘ shallowUnsplitPorts' + shallowSplitPortNames _ = shallowSplitPortNames' (_ :: r) + +class ShallowSplitPorts' r p | r -> p where + shallowSplitPorts' :: r -> p + shallowUnsplitPorts' :: p -> r + shallowSplitPortNames' :: r -> String -> List String + +instance (ShallowSplitPorts' a p, ShallowSplitPorts' b q, AppendTuple p q r) => ShallowSplitPorts' (a, b) r where + shallowSplitPorts' (a, b) = shallowSplitPorts' a `appendTuple` shallowSplitPorts' b + shallowUnsplitPorts' x = case splitTuple x of + (a, b) -> (shallowUnsplitPorts' a, shallowUnsplitPorts' b) + shallowSplitPortNames' _ base = + shallowSplitPortNames' (_ :: a) base `List.append` shallowSplitPortNames' (_ :: b) base + +instance ShallowSplitPorts' () () where + shallowSplitPorts' _ = () + shallowUnsplitPorts' _ = () + shallowSplitPortNames' _ _ = Nil + +instance ShallowSplitPorts' (Vector 0 r) () where + shallowSplitPorts' _ = () + shallowUnsplitPorts' _ = nil + shallowSplitPortNames' _ _ = Nil + +instance (ShallowSplitPorts' r p1, Add n1 1 n, ShallowSplitPorts' (Vector n1 r) p2, AppendTuple p1 p2 p) => + ShallowSplitPorts' (Vector n r) p where + shallowSplitPorts' v = shallowSplitPorts' (head v) `appendTuple` shallowSplitPorts' (tail v) + shallowUnsplitPorts' x = case splitTuple x of + (y, z) -> shallowUnsplitPorts' y :> shallowUnsplitPorts' z + shallowSplitPortNames' _ base = + let genElem i = shallowSplitPortNames' (_ :: r) (base +++ "_" +++ integerToString i) + in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) + +instance (ShallowSplitPorts' r p) => ShallowSplitPorts' (Meta (MetaField name idx) r) p where + shallowSplitPorts' (Meta x) = shallowSplitPorts' x + shallowUnsplitPorts' = Meta ∘ shallowUnsplitPorts' + shallowSplitPortNames' _ base = shallowSplitPortNames' (_ :: r) $ + if stringHead (stringOf name) == '_' + then base +++ stringOf name + else base +++ "_" +++ stringOf name + +instance (ShallowSplitPorts' r p) => ShallowSplitPorts' (Meta m r) p where + shallowSplitPorts' (Meta x) = shallowSplitPorts' x + shallowUnsplitPorts' = Meta ∘ shallowUnsplitPorts' + shallowSplitPortNames' _ = shallowSplitPortNames' (_ :: r) + +instance (SplitPorts a p) => ShallowSplitPorts' (Conc a) p where + shallowSplitPorts' (Conc x) = splitPorts x + shallowUnsplitPorts' = Conc ∘ unsplitPorts + shallowSplitPortNames' _ = portNames (_ :: a) + + +-- Helper class using generics, to recursively split structs and vectors into a tuple of ports. +class DeepSplitPorts a p | a -> p where + deepSplitPorts :: a -> p + deepUnsplitPorts :: p -> a + deepSplitPortNames :: a -> String -> List String + +instance DeepSplitPorts () () where + deepSplitPorts _ = () + deepUnsplitPorts _ = () + deepSplitPortNames _ _ = Nil + +instance (DeepSplitTuplePorts (a, b) r) => DeepSplitPorts (a, b) r where + deepSplitPorts = deepSplitTuplePorts + deepUnsplitPorts = deepUndeepSplitTuplePorts + deepSplitPortNames = deepSplitTuplePortNames 1 + +class DeepSplitTuplePorts a p | a -> p where + deepSplitTuplePorts :: a -> p + deepUndeepSplitTuplePorts :: p -> a + deepSplitTuplePortNames :: Integer -> a -> String -> List String + +instance (DeepSplitPorts a p, DeepSplitTuplePorts b q, AppendTuple p q r) => DeepSplitTuplePorts (a, b) r where + deepSplitTuplePorts (a, b) = deepSplitPorts a `appendTuple` deepSplitTuplePorts b + deepUndeepSplitTuplePorts x = case splitTuple x of + (a, b) -> (deepUnsplitPorts a, deepUndeepSplitTuplePorts b) + deepSplitTuplePortNames i _ base = + deepSplitPortNames (_ :: a) (base +++ "_" +++ integerToString i) `List.append` + deepSplitTuplePortNames (i + 1) (_ :: b) base + +instance (DeepSplitPorts a p) => DeepSplitTuplePorts a p where + deepSplitTuplePorts = deepSplitPorts + deepUndeepSplitTuplePorts x = deepUnsplitPorts x + deepSplitTuplePortNames i _ base = deepSplitPortNames (_ :: a) $ base +++ "_" +++ integerToString i + + +instance (Generic a r, DeepSplitPorts' r a p) => + DeepSplitPorts a p where + deepSplitPorts = deepSplitPorts' (_ :: r) + deepUnsplitPorts = deepUnsplitPorts' (_ :: r) + deepSplitPortNames = deepSplitPortNames' (_ :: r) + +class DeepSplitPorts' r a p | r a -> p where + deepSplitPorts' :: r -> a -> p + deepUnsplitPorts' :: r -> p -> a + deepSplitPortNames' :: r -> a -> String -> List String + +instance (SplitPorts a p) => DeepSplitPorts' r a p where + deepSplitPorts' _ = splitPorts + deepUnsplitPorts' _ = unsplitPorts + deepSplitPortNames' _ = portNames + +instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where + deepSplitPorts' _ = deepSplitPorts'' ∘ from + deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' + deepSplitPortNames' _ _ = deepSplitPortNames'' (_ :: r) + +class DeepSplitPorts'' r p | r -> p where + deepSplitPorts'' :: r -> p + deepUnsplitPorts'' :: p -> r + deepSplitPortNames'' :: r -> String -> List String + +instance (DeepSplitPorts'' a p, DeepSplitPorts'' b q, AppendTuple p q r) => DeepSplitPorts'' (a, b) r where + deepSplitPorts'' (a, b) = deepSplitPorts'' a `appendTuple` deepSplitPorts'' b + deepUnsplitPorts'' x = case splitTuple x of + (a, b) -> (deepUnsplitPorts'' a, deepUnsplitPorts'' b) + deepSplitPortNames'' _ base = + deepSplitPortNames'' (_ :: a) base `List.append` deepSplitPortNames'' (_ :: b) base + +instance DeepSplitPorts'' () () where + deepSplitPorts'' _ = () + deepUnsplitPorts'' _ = () + deepSplitPortNames'' _ _ = Nil + +instance DeepSplitPorts'' (Vector 0 r) () where + deepSplitPorts'' _ = () + deepUnsplitPorts'' _ = nil + deepSplitPortNames'' _ _ = Nil + +instance (DeepSplitPorts'' r p1, Add n1 1 n, DeepSplitPorts'' (Vector n1 r) p2, AppendTuple p1 p2 p) => + DeepSplitPorts'' (Vector n r) p where + deepSplitPorts'' v = deepSplitPorts'' (head v) `appendTuple` deepSplitPorts'' (tail v) + deepUnsplitPorts'' x = case splitTuple x of + (y, z) -> deepUnsplitPorts'' y :> deepUnsplitPorts'' z + deepSplitPortNames'' _ base = + let genElem i = deepSplitPortNames'' (_ :: r) (base +++ "_" +++ integerToString i) + in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) + +instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta (MetaField name idx) r) p where + deepSplitPorts'' (Meta x) = deepSplitPorts'' x + deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' + deepSplitPortNames'' _ base = deepSplitPortNames'' (_ :: r) $ + if stringHead (stringOf name) == '_' + then base +++ stringOf name + else base +++ "_" +++ stringOf name + +instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta m r) p where + deepSplitPorts'' (Meta x) = deepSplitPorts'' x + deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' + deepSplitPortNames'' _ = deepSplitPortNames'' (_ :: r) + +instance (DeepSplitPorts a p) => DeepSplitPorts'' (Conc a) p where + deepSplitPorts'' (Conc x) = deepSplitPorts x + deepUnsplitPorts'' = Conc ∘ deepUnsplitPorts + deepSplitPortNames'' _ = deepSplitPortNames (_ :: a) diff --git a/src/Libraries/Base1/Vector.bs b/src/Libraries/Base1/Vector.bs index 6006abd41..70d410993 100644 --- a/src/Libraries/Base1/Vector.bs +++ b/src/Libraries/Base1/Vector.bs @@ -1362,17 +1362,3 @@ instance (PrimMakeUninitialized'' r) => PrimMakeUninitialized'' (Vector n r) whe instance (PrimDeepSeqCond' r) => PrimDeepSeqCond' (Vector n r) where primDeepSeqCond' = flip $ foldr primDeepSeqCond' - -instance DeepSplitPorts'' (Vector 0 r) () where - deepSplitPorts'' _ = () - deepUnsplitPorts'' _ = nil - deepSplitPortNames'' _ _ = Nil - -instance (DeepSplitPorts'' r p1, Add n1 1 n, DeepSplitPorts'' (Vector n1 r) p2, AppendTuple p1 p2 p) => - DeepSplitPorts'' (Vector n r) p where - deepSplitPorts'' v = deepSplitPorts'' (head v) `appendTuple` deepSplitPorts'' (tail v) - deepUnsplitPorts'' x = case splitTuple x of - (y, z) -> deepUnsplitPorts'' y :> deepUnsplitPorts'' z - deepSplitPortNames'' _ base = - let genElem i = deepSplitPortNames'' (_ :: r) (base +++ "_" +++ integerToString i) - in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) diff --git a/src/Libraries/Base1/depends.mk b/src/Libraries/Base1/depends.mk index 8f4a2fe13..c008d4bea 100644 --- a/src/Libraries/Base1/depends.mk +++ b/src/Libraries/Base1/depends.mk @@ -1,5 +1,5 @@ ## Automatically generated by bluetcl -exec makedepend -- Do NOT EDIT -## Date: Tue 08 Dec 2020 09:49:58 PM UTC +## Date: Fri Aug 16 08:35:42 PM PDT 2024 ## Command: bluetcl -exec makedepend -bdir $(BUILDDIR) *.bs* $(BUILDDIR)/ActionSeq.bo: ActionSeq.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo @@ -35,4 +35,5 @@ $(BUILDDIR)/Real.bo: Real.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/RegFile.bo: RegFile.bs $(BUILDDIR)/ConfigReg.bo $(BUILDDIR)/List.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/Reserved.bo: Reserved.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/RevertingVirtualReg.bo: RevertingVirtualReg.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo +$(BUILDDIR)/SplitPorts.bo: SplitPorts.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/Vector.bo: Vector.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Array.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo From a52f2e62e60591256a503b785cc47d6974d10931 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 15:23:59 -0700 Subject: [PATCH 28/43] More efficient implementation of splitting vectors --- src/Libraries/Base1/SplitPorts.bs | 28 +++++----------- src/Libraries/Base1/Vector.bs | 56 ++++++++++++++++++++++++++++++- 2 files changed, 63 insertions(+), 21 deletions(-) diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index 708c65b30..3f4694b5b 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -51,16 +51,9 @@ instance ShallowSplitPorts' () () where shallowUnsplitPorts' _ = () shallowSplitPortNames' _ _ = Nil -instance ShallowSplitPorts' (Vector 0 r) () where - shallowSplitPorts' _ = () - shallowUnsplitPorts' _ = nil - shallowSplitPortNames' _ _ = Nil - -instance (ShallowSplitPorts' r p1, Add n1 1 n, ShallowSplitPorts' (Vector n1 r) p2, AppendTuple p1 p2 p) => - ShallowSplitPorts' (Vector n r) p where - shallowSplitPorts' v = shallowSplitPorts' (head v) `appendTuple` shallowSplitPorts' (tail v) - shallowUnsplitPorts' x = case splitTuple x of - (y, z) -> shallowUnsplitPorts' y :> shallowUnsplitPorts' z +instance (ShallowSplitPorts' r p1, ConcatTuple n p1 p) => ShallowSplitPorts' (Vector n r) p where + shallowSplitPorts' = concatTuple ∘ map shallowSplitPorts' + shallowUnsplitPorts' = map shallowUnsplitPorts' ∘ unconcatTuple shallowSplitPortNames' _ base = let genElem i = shallowSplitPortNames' (_ :: r) (base +++ "_" +++ integerToString i) in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) @@ -130,11 +123,13 @@ class DeepSplitPorts' r a p | r a -> p where deepUnsplitPorts' :: r -> p -> a deepSplitPortNames' :: r -> a -> String -> List String +-- Terminate recursion for n /= 1 constructors instance (SplitPorts a p) => DeepSplitPorts' r a p where deepSplitPorts' _ = splitPorts deepUnsplitPorts' _ = unsplitPorts deepSplitPortNames' _ = portNames +-- Recurse into the fields of a struct instance (Generic a r, DeepSplitPorts'' r p) => DeepSplitPorts' (Meta (MetaData name pkg args 1) r') a p where deepSplitPorts' _ = deepSplitPorts'' ∘ from deepUnsplitPorts' _ = to ∘ deepUnsplitPorts'' @@ -157,16 +152,9 @@ instance DeepSplitPorts'' () () where deepUnsplitPorts'' _ = () deepSplitPortNames'' _ _ = Nil -instance DeepSplitPorts'' (Vector 0 r) () where - deepSplitPorts'' _ = () - deepUnsplitPorts'' _ = nil - deepSplitPortNames'' _ _ = Nil - -instance (DeepSplitPorts'' r p1, Add n1 1 n, DeepSplitPorts'' (Vector n1 r) p2, AppendTuple p1 p2 p) => - DeepSplitPorts'' (Vector n r) p where - deepSplitPorts'' v = deepSplitPorts'' (head v) `appendTuple` deepSplitPorts'' (tail v) - deepUnsplitPorts'' x = case splitTuple x of - (y, z) -> deepUnsplitPorts'' y :> deepUnsplitPorts'' z +instance (DeepSplitPorts'' r p1, ConcatTuple n p1 p) => DeepSplitPorts'' (Vector n r) p where + deepSplitPorts'' = concatTuple ∘ map deepSplitPorts'' + deepUnsplitPorts'' = map deepUnsplitPorts'' ∘ unconcatTuple deepSplitPortNames'' _ base = let genElem i = deepSplitPortNames'' (_ :: r) (base +++ "_" +++ integerToString i) in List.concat $ List.map genElem $ List.upto 0 (valueOf n - 1) diff --git a/src/Libraries/Base1/Vector.bs b/src/Libraries/Base1/Vector.bs index 70d410993..82a37d9cb 100644 --- a/src/Libraries/Base1/Vector.bs +++ b/src/Libraries/Base1/Vector.bs @@ -19,7 +19,8 @@ package Vector( find, findElem, findIndex, countLeadingZeros, countElem, countIf, countOnes, countOnesAlt, rotateBy, rotateBitsBy, - readVReg, writeVReg, toChunks, drop, Ascii + readVReg, writeVReg, toChunks, drop, Ascii, + ConcatTuple(..), ConcatTuple'(..) ) where import List @@ -1255,6 +1256,59 @@ toChunks x = let padding = (0 :: Bit ch_sz) in unpack(tmp[v_sz-1:0]) + +class ConcatTuple n a b | n a -> b where + concatTuple :: Vector n a -> b + unconcatTuple :: b -> Vector n a + +instance ConcatTuple 0 a () where + concatTuple _ = () + unconcatTuple _ = nil + +instance ConcatTuple 1 a a where + concatTuple v = head v + unconcatTuple x = cons x nil + +-- Linear recursive implementation: O(n^2) +-- instance (Add n1 1 n, ConcatTuple n1 a b, AppendTuple a b c) => ConcatTuple n a c where +-- concatTuple v = appendTuple (head v) $ concatTuple (tail v) +-- unconcatTuple x = case splitTuple x of +-- (y, z) -> cons y $ unconcatTuple z + +-- O(n lg n) optimization: split into chunks that are powers of 2 +instance (Add lgn 1 (TLog (TAdd n 1)), Add (TExp lgn) n1 n, ConcatTuple n1 a b, ConcatTuple' lgn a c, AppendTuple b c d) => + ConcatTuple n a d where + concatTuple v = + let v1 :: Vector n1 a = take v + v2 :: Vector (TExp lgn) a = drop v + in concatTuple v1 `appendTuple` concatTuple' v2 + unconcatTuple x = + let res :: (b, c) = splitTuple x + v1 :: Vector n1 a = unconcatTuple res.fst + v2 :: Vector (TExp lgn) a = unconcatTuple' res.snd + in append v1 v2 + +-- Concatenate a vector of 2^n tuples +class ConcatTuple' n a b | n a -> b where + concatTuple' :: Vector (TExp n) a -> b + unconcatTuple' :: b -> Vector (TExp n) a + +instance ConcatTuple' 0 a a where + concatTuple' v = head v + unconcatTuple' x = cons x nil + +instance (Add n1 1 n, ConcatTuple' n1 a b, AppendTuple b b c) => ConcatTuple' n a c where + concatTuple' v = + let v1 :: Vector (TExp n1) a = take v + v2 :: Vector (TExp n1) a = drop v + in concatTuple' v1 `appendTuple` concatTuple' v2 + unconcatTuple' x = + let res :: (b, b) = splitTuple x + v1 :: Vector (TExp n1) a = unconcatTuple' res.fst + v2 :: Vector (TExp n1) a = unconcatTuple' res.snd + in append v1 v2 + + --@ \item{\bf Examples Using the Vector Type} --@ --@ The following example shows some common uses of the {\te{Vector}} From 36a4dc21b83d7139f83f6f8be07b550a91391834 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 16:33:30 -0700 Subject: [PATCH 29/43] Avoid extra _1 suffix for DeepSplitPorts on Int/UInt --- src/Libraries/Base1/SplitPorts.bs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index 3f4694b5b..dd792ffc3 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -83,12 +83,22 @@ class DeepSplitPorts a p | a -> p where deepUnsplitPorts :: p -> a deepSplitPortNames :: a -> String -> List String +instance DeepSplitPorts (UInt n) (Port (UInt n)) where + deepSplitPorts = Port + deepUnsplitPorts (Port x) = x + deepSplitPortNames _ base = Cons base Nil + +instance DeepSplitPorts (Int n) (Port (Int n)) where + deepSplitPorts = Port + deepUnsplitPorts (Port x) = x + deepSplitPortNames _ base = Cons base Nil + instance DeepSplitPorts () () where deepSplitPorts _ = () deepUnsplitPorts _ = () deepSplitPortNames _ _ = Nil -instance (DeepSplitTuplePorts (a, b) r) => DeepSplitPorts (a, b) r where +instance (DeepSplitTuplePorts (a, b) p) => DeepSplitPorts (a, b) p where deepSplitPorts = deepSplitTuplePorts deepUnsplitPorts = deepUndeepSplitTuplePorts deepSplitPortNames = deepSplitTuplePortNames 1 @@ -112,8 +122,7 @@ instance (DeepSplitPorts a p) => DeepSplitTuplePorts a p where deepSplitTuplePortNames i _ base = deepSplitPortNames (_ :: a) $ base +++ "_" +++ integerToString i -instance (Generic a r, DeepSplitPorts' r a p) => - DeepSplitPorts a p where +instance (Generic a r, DeepSplitPorts' r a p) => DeepSplitPorts a p where deepSplitPorts = deepSplitPorts' (_ :: r) deepUnsplitPorts = deepUnsplitPorts' (_ :: r) deepSplitPortNames = deepSplitPortNames' (_ :: r) From 8999a65dbb05fc6d183d8644c2d1f1c4718d6817 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 16:33:58 -0700 Subject: [PATCH 30/43] Add test cases for port splitting --- testsuite/bsc.verilog/splitports/DeepSplit.bs | 59 ++++++++++++++ .../bsc.verilog/splitports/InstanceSplit.bs | 76 +++++++++++++++++++ testsuite/bsc.verilog/splitports/Makefile | 5 ++ .../bsc.verilog/splitports/ShallowSplit.bs | 59 ++++++++++++++ .../bsc.verilog/splitports/splitports.exp | 39 ++++++++++ .../splitports/sysDeepSplit.out.expected | 5 ++ .../splitports/sysInstanceSplit.out.expected | 5 ++ .../splitports/sysShallowSplit.out.expected | 5 ++ 8 files changed, 253 insertions(+) create mode 100644 testsuite/bsc.verilog/splitports/DeepSplit.bs create mode 100644 testsuite/bsc.verilog/splitports/InstanceSplit.bs create mode 100644 testsuite/bsc.verilog/splitports/Makefile create mode 100644 testsuite/bsc.verilog/splitports/ShallowSplit.bs create mode 100644 testsuite/bsc.verilog/splitports/splitports.exp create mode 100644 testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysInstanceSplit.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysShallowSplit.out.expected diff --git a/testsuite/bsc.verilog/splitports/DeepSplit.bs b/testsuite/bsc.verilog/splitports/DeepSplit.bs new file mode 100644 index 000000000..79bd97470 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/DeepSplit.bs @@ -0,0 +1,59 @@ +package DeepSplit where + +import Vector +import BuildVector +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +struct Bar = + v :: Vector 3 Bool + w :: (Bool, UInt 16) + z :: Foo + -- No Bits instance needed + +struct Baz = + a :: Maybe Foo + b :: Bar + c :: Vector 3 (Vector 8 Foo, Bar) + d :: () + e :: Vector 0 Foo + -- No Bits instance needed + +interface SplitTest = + putFoo :: DeepSplit Foo -> Action + putBar :: DeepSplit Bar -> Action {-# prefix = "PUT_BAR" #-} + putFooBar :: DeepSplit Foo -> DeepSplit Bar -> Action {-# arg_names = ["fooIn", "barIn"] #-} + putFoos :: DeepSplit (Vector 50 Foo) -> Action + putBaz :: DeepSplit Baz -> Action + + +{-# synthesize mkDeepSplitTest #-} +mkDeepSplitTest :: Module SplitTest +mkDeepSplitTest = + module + interface + putFoo (DeepSplit x) = $display "putFoo: " (cshow x) + putBar (DeepSplit x) = $display "putBar: " (cshow x) + putFooBar (DeepSplit x) (DeepSplit y) = $display "putFooBar: " (cshow x) " " (cshow y) + putFoos (DeepSplit x) = $display "putFoos: " (cshow x) + putBaz (DeepSplit x) = $display "putBaz: " (cshow x) + +{-# synthesize sysDeepSplit #-} +sysDeepSplit :: Module Empty +sysDeepSplit = + module + s <- mkDeepSplitTest + i :: Reg (UInt 8) <- mkReg 0 + rules + when True ==> i := i + 1 + when i == 0 ==> s.putFoo $ DeepSplit $ Foo { x = 1; y = 2; } + when i == 1 ==> s.putBar $ DeepSplit $ Bar { v = vec True False True; w = (True, 0x1234); z = Foo { x = 3; y = 4; } } + when i == 2 ==> s.putFooBar (DeepSplit $ Foo { x = 5; y = 6; }) (DeepSplit $ Bar { v = vec False True False; w = (False, 0x5678); z = Foo { x = 7; y = 8; } }) + when i == 3 ==> s.putFoos $ DeepSplit $ genWith $ \ j -> Foo { x = fromInteger $ 9 + j / 2; y = fromInteger $ 10 - 2*j / 3; } + when i == 4 ==> s.putBaz $ DeepSplit $ Baz { a = Just $ Foo { x = 9; y = 10; }; b = Bar { v = vec True False False; w = (True, 0x1234); z = Foo { x = 3; y = 4; }; }; c = vec (vec (Foo { x = 11; y = 12; }) (Foo { x = 13; y = 14; }) (Foo { x = 15; y = 16; }) (Foo { x = 17; y = 18; }) (Foo { x = 19; y = 20; }) (Foo { x = 21; y = 22; }) (Foo { x = 23; y = 24; }) (Foo { x = 25; y = 26; }), Bar { v = vec True False True; w = (True, 0xBEEF); z = Foo { x = 3; y = 4; } }) (vec (Foo { x = 27; y = 28; }) (Foo { x = 29; y = 30; }) (Foo { x = 31; y = 32; }) (Foo { x = 33; y = 34; }) (Foo { x = 35; y = 36; }) (Foo { x = 37; y = 38; }) (Foo { x = 39; y = 40; }) (Foo { x = 41; y = 42; }), Bar { v = vec True False True; w = (True, 0x4321); z = Foo { x = 123; y = 42; } }) (vec (Foo { x = 43; y = 44; }) (Foo { x = 45; y = 46; }) (Foo { x = 47; y = 48; }) (Foo { x = 49; y = 50; }) (Foo { x = 51; y = 52; }) (Foo { x = 53; y = 54; }) (Foo { x = 55; y = 56; }) (Foo { x = 57; y = 58; }), Bar { v = vec True True True; w = (True, 0xAABB); z = Foo { x = 3; y = 4; } }); d = (); e = nil; } + when i == 5 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/InstanceSplit.bs b/testsuite/bsc.verilog/splitports/InstanceSplit.bs new file mode 100644 index 000000000..1e6a71314 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/InstanceSplit.bs @@ -0,0 +1,76 @@ +package InstanceSplit where + +import Vector +import BuildVector +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +instance SplitPorts Foo (Port (Int 8), Port Bool, Port (Bit 7)) where + splitPorts x = (Port x.x, Port (x.y > 0), Port $ truncate $ pack x.y) + unsplitPorts (Port x, Port s, Port y) = Foo { x = x; y = (if s then id else negate) $ unpack $ zeroExtend y; } + portNames _ base = Cons (base +++ "_x") $ Cons (base +++ "_ysign") $ Cons (base +++ "_yvalue") Nil + +struct Bar = + v :: Vector 3 Bool + w :: (Bool, UInt 16) + z :: Foo + deriving (Bits) + +-- XXX would be nice to be able to derive this +instance (ShallowSplitPorts Bar p) => SplitPorts Bar p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +struct Baz = + a :: Maybe Foo + b :: Bar + c :: Vector 3 (Vector 8 Foo, Bar) + d :: () + e :: Vector 0 Foo + -- No Bits instance needed + +-- XXX would be nice to be able to derive this +instance (ShallowSplitPorts Baz p) => SplitPorts Baz p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +interface SplitTest = + putFoo :: Foo -> Action + putBar :: Bar -> Action {-# prefix = "PUT_BAR" #-} + putFooBar :: Foo -> Bar -> Action {-# arg_names = ["fooIn", "barIn"] #-} + putFoos :: (Vector 50 Foo) -> Action + putBaz :: Baz -> Action + + +{-# synthesize mkInstanceSplitTest #-} +mkInstanceSplitTest :: Module SplitTest +mkInstanceSplitTest = + module + interface + putFoo x = $display "putFoo: " (cshow x) + putBar x = $display "putBar: " (cshow x) + putFooBar x y = $display "putFooBar: " (cshow x) " " (cshow y) + putFoos x = $display "putFoos: " (cshow x) + putBaz x = $display "putBaz: " (cshow x) + +{-# synthesize sysInstanceSplit #-} +sysInstanceSplit :: Module Empty +sysInstanceSplit = + module + s <- mkInstanceSplitTest + i :: Reg (UInt 8) <- mkReg 0 + rules + when True ==> i := i + 1 + when i == 0 ==> s.putFoo $ Foo { x = 1; y = 2; } + when i == 1 ==> s.putBar $ Bar { v = vec True False True; w = (True, 0x1234); z = Foo { x = 3; y = 4; } } + when i == 2 ==> s.putFooBar (Foo { x = 5; y = 6; }) (Bar { v = vec False True False; w = (False, 0x5678); z = Foo { x = 7; y = 8; } }) + when i == 3 ==> s.putFoos $ genWith $ \ j -> Foo { x = fromInteger $ 9 + j / 2; y = fromInteger $ 10 - 2*j / 3; } + when i == 4 ==> s.putBaz $ Baz { a = Just $ Foo { x = 9; y = 10; }; b = Bar { v = vec True False False; w = (True, 0x1234); z = Foo { x = 3; y = 4; }; }; c = vec (vec (Foo { x = 11; y = 12; }) (Foo { x = 13; y = 14; }) (Foo { x = 15; y = 16; }) (Foo { x = 17; y = 18; }) (Foo { x = 19; y = 20; }) (Foo { x = 21; y = 22; }) (Foo { x = 23; y = 24; }) (Foo { x = 25; y = 26; }), Bar { v = vec True False True; w = (True, 0xBEEF); z = Foo { x = 3; y = 4; } }) (vec (Foo { x = 27; y = 28; }) (Foo { x = 29; y = 30; }) (Foo { x = 31; y = 32; }) (Foo { x = 33; y = 34; }) (Foo { x = 35; y = 36; }) (Foo { x = 37; y = 38; }) (Foo { x = 39; y = 40; }) (Foo { x = 41; y = 42; }), Bar { v = vec True False True; w = (True, 0x4321); z = Foo { x = 123; y = 42; } }) (vec (Foo { x = 43; y = 44; }) (Foo { x = 45; y = 46; }) (Foo { x = 47; y = 48; }) (Foo { x = 49; y = 50; }) (Foo { x = 51; y = 52; }) (Foo { x = 53; y = 54; }) (Foo { x = 55; y = 56; }) (Foo { x = 57; y = 58; }), Bar { v = vec True True True; w = (True, 0xAABB); z = Foo { x = 3; y = 4; } }); d = (); e = nil; } + when i == 5 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/Makefile b/testsuite/bsc.verilog/splitports/Makefile new file mode 100644 index 000000000..b953e8132 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/Makefile @@ -0,0 +1,5 @@ +# for "make clean" to work everywhere + +CONFDIR = $(realpath ../..) + +include $(CONFDIR)/clean.mk diff --git a/testsuite/bsc.verilog/splitports/ShallowSplit.bs b/testsuite/bsc.verilog/splitports/ShallowSplit.bs new file mode 100644 index 000000000..11166e76a --- /dev/null +++ b/testsuite/bsc.verilog/splitports/ShallowSplit.bs @@ -0,0 +1,59 @@ +package ShallowSplit where + +import Vector +import BuildVector +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +struct Bar = + v :: Vector 3 Bool + w :: (Bool, UInt 16) + z :: Foo + deriving (Bits) + +struct Baz = + a :: Maybe Foo + b :: Bar + c :: Vector 3 (Vector 8 Foo, Bar) + d :: () + e :: Vector 0 Foo + -- No Bits instance needed + +interface SplitTest = + putFoo :: ShallowSplit Foo -> Action + putBar :: ShallowSplit Bar -> Action {-# prefix = "PUT_BAR" #-} + putFooBar :: ShallowSplit Foo -> ShallowSplit Bar -> Action {-# arg_names = ["fooIn", "barIn"] #-} + putFoos :: ShallowSplit (Vector 50 Foo) -> Action + putBaz :: ShallowSplit Baz -> Action + + +{-# synthesize mkShallowSplitTest #-} +mkShallowSplitTest :: Module SplitTest +mkShallowSplitTest = + module + interface + putFoo (ShallowSplit x) = $display "putFoo: " (cshow x) + putBar (ShallowSplit x) = $display "putBar: " (cshow x) + putFooBar (ShallowSplit x) (ShallowSplit y) = $display "putFooBar: " (cshow x) " " (cshow y) + putFoos (ShallowSplit x) = $display "putFoos: " (cshow x) + putBaz (ShallowSplit x) = $display "putBaz: " (cshow x) + +{-# synthesize sysShallowSplit #-} +sysShallowSplit :: Module Empty +sysShallowSplit = + module + s <- mkShallowSplitTest + i :: Reg (UInt 8) <- mkReg 0 + rules + when True ==> i := i + 1 + when i == 0 ==> s.putFoo $ ShallowSplit $ Foo { x = 1; y = 2; } + when i == 1 ==> s.putBar $ ShallowSplit $ Bar { v = vec True False True; w = (True, 0x1234); z = Foo { x = 3; y = 4; } } + when i == 2 ==> s.putFooBar (ShallowSplit $ Foo { x = 5; y = 6; }) (ShallowSplit $ Bar { v = vec False True False; w = (False, 0x5678); z = Foo { x = 7; y = 8; } }) + when i == 3 ==> s.putFoos $ ShallowSplit $ genWith $ \ j -> Foo { x = fromInteger $ 9 + j / 2; y = fromInteger $ 10 - 2*j / 3; } + when i == 4 ==> s.putBaz $ ShallowSplit $ Baz { a = Just $ Foo { x = 9; y = 10; }; b = Bar { v = vec True False False; w = (True, 0x1234); z = Foo { x = 3; y = 4; }; }; c = vec (vec (Foo { x = 11; y = 12; }) (Foo { x = 13; y = 14; }) (Foo { x = 15; y = 16; }) (Foo { x = 17; y = 18; }) (Foo { x = 19; y = 20; }) (Foo { x = 21; y = 22; }) (Foo { x = 23; y = 24; }) (Foo { x = 25; y = 26; }), Bar { v = vec True False True; w = (True, 0xBEEF); z = Foo { x = 3; y = 4; } }) (vec (Foo { x = 27; y = 28; }) (Foo { x = 29; y = 30; }) (Foo { x = 31; y = 32; }) (Foo { x = 33; y = 34; }) (Foo { x = 35; y = 36; }) (Foo { x = 37; y = 38; }) (Foo { x = 39; y = 40; }) (Foo { x = 41; y = 42; }), Bar { v = vec True False True; w = (True, 0x4321); z = Foo { x = 123; y = 42; } }) (vec (Foo { x = 43; y = 44; }) (Foo { x = 45; y = 46; }) (Foo { x = 47; y = 48; }) (Foo { x = 49; y = 50; }) (Foo { x = 51; y = 52; }) (Foo { x = 53; y = 54; }) (Foo { x = 55; y = 56; }) (Foo { x = 57; y = 58; }), Bar { v = vec True True True; w = (True, 0xAABB); z = Foo { x = 3; y = 4; } }); d = (); e = nil; } + when i == 5 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/splitports.exp b/testsuite/bsc.verilog/splitports/splitports.exp new file mode 100644 index 000000000..bf548ed20 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/splitports.exp @@ -0,0 +1,39 @@ + +test_c_veri ShallowSplit +if { $vtest == 1 } { + find_regexp mkShallowSplitTest.v {input \[7 : 0\] putFoo_1_x;} + find_regexp mkShallowSplitTest.v {input \[15 : 0\] PUT_BAR_1_z;} + find_regexp mkShallowSplitTest.v {input \[7 : 0\] putFooBar_fooIn_y;} + find_regexp mkShallowSplitTest.v {input \[16 : 0\] putFooBar_barIn_w;} + find_regexp mkShallowSplitTest.v {input \[15 : 0\] putFoos_1_0;} + find_regexp mkShallowSplitTest.v {input \[15 : 0\] putFoos_1_49;} + find_regexp mkShallowSplitTest.v {input \[16 : 0\] putBaz_1_a;} + find_regexp mkShallowSplitTest.v {input \[491 : 0\] putBaz_1_c;} +} + +test_c_veri DeepSplit +if { $vtest == 1 } { + find_regexp mkDeepSplitTest.v {input \[7 : 0\] putFoo_1_x;} + find_regexp mkDeepSplitTest.v {input PUT_BAR_1_v_2;} + find_regexp mkDeepSplitTest.v {input \[7 : 0\] PUT_BAR_1_z_y;} + find_regexp mkDeepSplitTest.v {input \[7 : 0\] putFooBar_fooIn_y;} + find_regexp mkDeepSplitTest.v {input putFooBar_barIn_v_2;} + find_regexp mkDeepSplitTest.v {input \[7 : 0\] putFoos_1_0_x;} + find_regexp mkDeepSplitTest.v {input \[7 : 0\] putFoos_1_49_y;} + find_regexp mkDeepSplitTest.v {input \[16 : 0\] putBaz_1_a;} + find_regexp mkDeepSplitTest.v {input \[7 : 0\] putBaz_1_c_2_1_7_y;} + find_regexp mkDeepSplitTest.v {input \[15 : 0\] putBaz_1_c_2_2_w_2;} +} + +test_c_veri InstanceSplit +if { $vtest == 1 } { + find_regexp mkInstanceSplitTest.v {input \[7 : 0\] putFoo_1_x;} + find_regexp mkInstanceSplitTest.v {input putFoo_1_ysign;} + find_regexp mkInstanceSplitTest.v {input \[6 : 0\] putFoo_1_yvalue;} + find_regexp mkInstanceSplitTest.v {input \[7 : 0\] PUT_BAR_1_z_x;} + find_regexp mkInstanceSplitTest.v {input \[6 : 0\] putFooBar_fooIn_yvalue;} + find_regexp mkInstanceSplitTest.v {input \[16 : 0\] putFooBar_barIn_w;} + find_regexp mkInstanceSplitTest.v {input \[799 : 0\] putFoos_1;} + find_regexp mkInstanceSplitTest.v {input \[16 : 0\] putBaz_1_a;} + find_regexp mkInstanceSplitTest.v {input \[491 : 0\] putBaz_1_c;} +} \ No newline at end of file diff --git a/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected b/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected new file mode 100644 index 000000000..bb4f2dc03 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected @@ -0,0 +1,5 @@ +putFoo: Foo {x= 1; y= 2} +putBar: Bar {v=[True, False, True]; w=(True, 4660); z=Foo {x= 3; y= 4}} +putFooBar: Foo {x= 5; y= 6} Bar {v=[False, True, False]; w=(False, 22136); z=Foo {x= 7; y= 8}} +putFoos: [Foo {x= 9; y= 10}, Foo {x= 9; y= 10}, Foo {x= 10; y= 9}, Foo {x= 10; y= 8}, Foo {x= 11; y= 8}, Foo {x= 11; y= 7}, Foo {x= 12; y= 6}, Foo {x= 12; y= 6}, Foo {x= 13; y= 5}, Foo {x= 13; y= 4}, Foo {x= 14; y= 4}, Foo {x= 14; y= 3}, Foo {x= 15; y= 2}, Foo {x= 15; y= 2}, Foo {x= 16; y= 1}, Foo {x= 16; y= 0}, Foo {x= 17; y= 0}, Foo {x= 17; y= -1}, Foo {x= 18; y= -2}, Foo {x= 18; y= -2}, Foo {x= 19; y= -3}, Foo {x= 19; y= -4}, Foo {x= 20; y= -4}, Foo {x= 20; y= -5}, Foo {x= 21; y= -6}, Foo {x= 21; y= -6}, Foo {x= 22; y= -7}, Foo {x= 22; y= -8}, Foo {x= 23; y= -8}, Foo {x= 23; y= -9}, Foo {x= 24; y= -10}, Foo {x= 24; y= -10}, Foo {x= 25; y= -11}, Foo {x= 25; y= -12}, Foo {x= 26; y= -12}, Foo {x= 26; y= -13}, Foo {x= 27; y= -14}, Foo {x= 27; y= -14}, Foo {x= 28; y= -15}, Foo {x= 28; y= -16}, Foo {x= 29; y= -16}, Foo {x= 29; y= -17}, Foo {x= 30; y= -18}, Foo {x= 30; y= -18}, Foo {x= 31; y= -19}, Foo {x= 31; y= -20}, Foo {x= 32; y= -20}, Foo {x= 32; y= -21}, Foo {x= 33; y= -22}, Foo {x= 33; y= -22}] +putBaz: Baz {a=Valid (Foo {x= 9; y= 10}); b=Bar {v=[True, False, False]; w=(True, 4660); z=Foo {x= 3; y= 4}}; c=[([Foo {x= 11; y= 12}, Foo {x= 13; y= 14}, Foo {x= 15; y= 16}, Foo {x= 17; y= 18}, Foo {x= 19; y= 20}, Foo {x= 21; y= 22}, Foo {x= 23; y= 24}, Foo {x= 25; y= 26}], Bar {v=[True, False, True]; w=(True, 48879); z=Foo {x= 3; y= 4}}), ([Foo {x= 27; y= 28}, Foo {x= 29; y= 30}, Foo {x= 31; y= 32}, Foo {x= 33; y= 34}, Foo {x= 35; y= 36}, Foo {x= 37; y= 38}, Foo {x= 39; y= 40}, Foo {x= 41; y= 42}], Bar {v=[True, False, True]; w=(True, 17185); z=Foo {x= 123; y= 42}}), ([Foo {x= 43; y= 44}, Foo {x= 45; y= 46}, Foo {x= 47; y= 48}, Foo {x= 49; y= 50}, Foo {x= 51; y= 52}, Foo {x= 53; y= 54}, Foo {x= 55; y= 56}, Foo {x= 57; y= 58}], Bar {v=[True, True, True]; w=(True, 43707); z=Foo {x= 3; y= 4}})]; d=(); e=[]} diff --git a/testsuite/bsc.verilog/splitports/sysInstanceSplit.out.expected b/testsuite/bsc.verilog/splitports/sysInstanceSplit.out.expected new file mode 100644 index 000000000..bb4f2dc03 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysInstanceSplit.out.expected @@ -0,0 +1,5 @@ +putFoo: Foo {x= 1; y= 2} +putBar: Bar {v=[True, False, True]; w=(True, 4660); z=Foo {x= 3; y= 4}} +putFooBar: Foo {x= 5; y= 6} Bar {v=[False, True, False]; w=(False, 22136); z=Foo {x= 7; y= 8}} +putFoos: [Foo {x= 9; y= 10}, Foo {x= 9; y= 10}, Foo {x= 10; y= 9}, Foo {x= 10; y= 8}, Foo {x= 11; y= 8}, Foo {x= 11; y= 7}, Foo {x= 12; y= 6}, Foo {x= 12; y= 6}, Foo {x= 13; y= 5}, Foo {x= 13; y= 4}, Foo {x= 14; y= 4}, Foo {x= 14; y= 3}, Foo {x= 15; y= 2}, Foo {x= 15; y= 2}, Foo {x= 16; y= 1}, Foo {x= 16; y= 0}, Foo {x= 17; y= 0}, Foo {x= 17; y= -1}, Foo {x= 18; y= -2}, Foo {x= 18; y= -2}, Foo {x= 19; y= -3}, Foo {x= 19; y= -4}, Foo {x= 20; y= -4}, Foo {x= 20; y= -5}, Foo {x= 21; y= -6}, Foo {x= 21; y= -6}, Foo {x= 22; y= -7}, Foo {x= 22; y= -8}, Foo {x= 23; y= -8}, Foo {x= 23; y= -9}, Foo {x= 24; y= -10}, Foo {x= 24; y= -10}, Foo {x= 25; y= -11}, Foo {x= 25; y= -12}, Foo {x= 26; y= -12}, Foo {x= 26; y= -13}, Foo {x= 27; y= -14}, Foo {x= 27; y= -14}, Foo {x= 28; y= -15}, Foo {x= 28; y= -16}, Foo {x= 29; y= -16}, Foo {x= 29; y= -17}, Foo {x= 30; y= -18}, Foo {x= 30; y= -18}, Foo {x= 31; y= -19}, Foo {x= 31; y= -20}, Foo {x= 32; y= -20}, Foo {x= 32; y= -21}, Foo {x= 33; y= -22}, Foo {x= 33; y= -22}] +putBaz: Baz {a=Valid (Foo {x= 9; y= 10}); b=Bar {v=[True, False, False]; w=(True, 4660); z=Foo {x= 3; y= 4}}; c=[([Foo {x= 11; y= 12}, Foo {x= 13; y= 14}, Foo {x= 15; y= 16}, Foo {x= 17; y= 18}, Foo {x= 19; y= 20}, Foo {x= 21; y= 22}, Foo {x= 23; y= 24}, Foo {x= 25; y= 26}], Bar {v=[True, False, True]; w=(True, 48879); z=Foo {x= 3; y= 4}}), ([Foo {x= 27; y= 28}, Foo {x= 29; y= 30}, Foo {x= 31; y= 32}, Foo {x= 33; y= 34}, Foo {x= 35; y= 36}, Foo {x= 37; y= 38}, Foo {x= 39; y= 40}, Foo {x= 41; y= 42}], Bar {v=[True, False, True]; w=(True, 17185); z=Foo {x= 123; y= 42}}), ([Foo {x= 43; y= 44}, Foo {x= 45; y= 46}, Foo {x= 47; y= 48}, Foo {x= 49; y= 50}, Foo {x= 51; y= 52}, Foo {x= 53; y= 54}, Foo {x= 55; y= 56}, Foo {x= 57; y= 58}], Bar {v=[True, True, True]; w=(True, 43707); z=Foo {x= 3; y= 4}})]; d=(); e=[]} diff --git a/testsuite/bsc.verilog/splitports/sysShallowSplit.out.expected b/testsuite/bsc.verilog/splitports/sysShallowSplit.out.expected new file mode 100644 index 000000000..bb4f2dc03 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysShallowSplit.out.expected @@ -0,0 +1,5 @@ +putFoo: Foo {x= 1; y= 2} +putBar: Bar {v=[True, False, True]; w=(True, 4660); z=Foo {x= 3; y= 4}} +putFooBar: Foo {x= 5; y= 6} Bar {v=[False, True, False]; w=(False, 22136); z=Foo {x= 7; y= 8}} +putFoos: [Foo {x= 9; y= 10}, Foo {x= 9; y= 10}, Foo {x= 10; y= 9}, Foo {x= 10; y= 8}, Foo {x= 11; y= 8}, Foo {x= 11; y= 7}, Foo {x= 12; y= 6}, Foo {x= 12; y= 6}, Foo {x= 13; y= 5}, Foo {x= 13; y= 4}, Foo {x= 14; y= 4}, Foo {x= 14; y= 3}, Foo {x= 15; y= 2}, Foo {x= 15; y= 2}, Foo {x= 16; y= 1}, Foo {x= 16; y= 0}, Foo {x= 17; y= 0}, Foo {x= 17; y= -1}, Foo {x= 18; y= -2}, Foo {x= 18; y= -2}, Foo {x= 19; y= -3}, Foo {x= 19; y= -4}, Foo {x= 20; y= -4}, Foo {x= 20; y= -5}, Foo {x= 21; y= -6}, Foo {x= 21; y= -6}, Foo {x= 22; y= -7}, Foo {x= 22; y= -8}, Foo {x= 23; y= -8}, Foo {x= 23; y= -9}, Foo {x= 24; y= -10}, Foo {x= 24; y= -10}, Foo {x= 25; y= -11}, Foo {x= 25; y= -12}, Foo {x= 26; y= -12}, Foo {x= 26; y= -13}, Foo {x= 27; y= -14}, Foo {x= 27; y= -14}, Foo {x= 28; y= -15}, Foo {x= 28; y= -16}, Foo {x= 29; y= -16}, Foo {x= 29; y= -17}, Foo {x= 30; y= -18}, Foo {x= 30; y= -18}, Foo {x= 31; y= -19}, Foo {x= 31; y= -20}, Foo {x= 32; y= -20}, Foo {x= 32; y= -21}, Foo {x= 33; y= -22}, Foo {x= 33; y= -22}] +putBaz: Baz {a=Valid (Foo {x= 9; y= 10}); b=Bar {v=[True, False, False]; w=(True, 4660); z=Foo {x= 3; y= 4}}; c=[([Foo {x= 11; y= 12}, Foo {x= 13; y= 14}, Foo {x= 15; y= 16}, Foo {x= 17; y= 18}, Foo {x= 19; y= 20}, Foo {x= 21; y= 22}, Foo {x= 23; y= 24}, Foo {x= 25; y= 26}], Bar {v=[True, False, True]; w=(True, 48879); z=Foo {x= 3; y= 4}}), ([Foo {x= 27; y= 28}, Foo {x= 29; y= 30}, Foo {x= 31; y= 32}, Foo {x= 33; y= 34}, Foo {x= 35; y= 36}, Foo {x= 37; y= 38}, Foo {x= 39; y= 40}, Foo {x= 41; y= 42}], Bar {v=[True, False, True]; w=(True, 17185); z=Foo {x= 123; y= 42}}), ([Foo {x= 43; y= 44}, Foo {x= 45; y= 46}, Foo {x= 47; y= 48}, Foo {x= 49; y= 50}, Foo {x= 51; y= 52}, Foo {x= 53; y= 54}, Foo {x= 55; y= 56}, Foo {x= 57; y= 58}], Bar {v=[True, True, True]; w=(True, 43707); z=Foo {x= 3; y= 4}})]; d=(); e=[]} From be3d910088008f10bfb790c4552010780fb0d7f7 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 18:29:59 -0700 Subject: [PATCH 31/43] Add test of DeepSplitPorts with an explicit non-recursive instance --- src/Libraries/Base1/SplitPorts.bs | 10 ++++++++-- testsuite/bsc.verilog/splitports/DeepSplit.bs | 20 ++++++++++++++++++- .../bsc.verilog/splitports/splitports.exp | 1 + .../splitports/sysDeepSplit.out.expected | 1 + 4 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index dd792ffc3..96e0c6ba8 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -5,12 +5,13 @@ package SplitPorts where import qualified List import Vector - - -- Newtype tags to indicate that a types should be split (recursively or not) into ports data ShallowSplit a = ShallowSplit a data DeepSplit a = DeepSplit a +-- Tag to indicate that the DeepSplitPorts recursion should terminate +data NoSplit a = NoSplit a + instance (ShallowSplitPorts a p) => SplitPorts (ShallowSplit a) p where splitPorts (ShallowSplit x) = shallowSplitPorts x unsplitPorts = ShallowSplit ∘ shallowUnsplitPorts @@ -21,6 +22,11 @@ instance (DeepSplitPorts a p) => SplitPorts (DeepSplit a) p where unsplitPorts = DeepSplit ∘ deepUnsplitPorts portNames _ = deepSplitPortNames (_ :: a) +instance DeepSplitPorts (NoSplit a) (Port a) where + splitPorts (NoSplit x) = Port x + unsplitPorts (Port x) = NoSplit x + portNames _ base = List.Cons base List.Nil + -- Helper class using generics, to split a struct or vector into a tuple of ports. class ShallowSplitPorts a p | a -> p where diff --git a/testsuite/bsc.verilog/splitports/DeepSplit.bs b/testsuite/bsc.verilog/splitports/DeepSplit.bs index 79bd97470..5b9eb8c2d 100644 --- a/testsuite/bsc.verilog/splitports/DeepSplit.bs +++ b/testsuite/bsc.verilog/splitports/DeepSplit.bs @@ -24,12 +24,28 @@ struct Baz = e :: Vector 0 Foo -- No Bits instance needed +struct Quix = + q :: Int 3 + v :: Bool + deriving (Bits) + +-- Don't recurse into Quix with DeepSplitPorts +instance DeepSplitPorts Quix (Port Quix) where + deepSplitPorts x = Port x + deepUnsplitPorts (Port x) = x + deepSplitPortNames _ base = Cons (base) Nil + +struct Zug = + qs :: Vector 2 Quix + blob :: Bool + interface SplitTest = putFoo :: DeepSplit Foo -> Action putBar :: DeepSplit Bar -> Action {-# prefix = "PUT_BAR" #-} putFooBar :: DeepSplit Foo -> DeepSplit Bar -> Action {-# arg_names = ["fooIn", "barIn"] #-} putFoos :: DeepSplit (Vector 50 Foo) -> Action putBaz :: DeepSplit Baz -> Action + putZug :: DeepSplit Zug -> Action {-# synthesize mkDeepSplitTest #-} @@ -42,6 +58,7 @@ mkDeepSplitTest = putFooBar (DeepSplit x) (DeepSplit y) = $display "putFooBar: " (cshow x) " " (cshow y) putFoos (DeepSplit x) = $display "putFoos: " (cshow x) putBaz (DeepSplit x) = $display "putBaz: " (cshow x) + putZug (DeepSplit x) = $display "putZug: " (cshow x) {-# synthesize sysDeepSplit #-} sysDeepSplit :: Module Empty @@ -56,4 +73,5 @@ sysDeepSplit = when i == 2 ==> s.putFooBar (DeepSplit $ Foo { x = 5; y = 6; }) (DeepSplit $ Bar { v = vec False True False; w = (False, 0x5678); z = Foo { x = 7; y = 8; } }) when i == 3 ==> s.putFoos $ DeepSplit $ genWith $ \ j -> Foo { x = fromInteger $ 9 + j / 2; y = fromInteger $ 10 - 2*j / 3; } when i == 4 ==> s.putBaz $ DeepSplit $ Baz { a = Just $ Foo { x = 9; y = 10; }; b = Bar { v = vec True False False; w = (True, 0x1234); z = Foo { x = 3; y = 4; }; }; c = vec (vec (Foo { x = 11; y = 12; }) (Foo { x = 13; y = 14; }) (Foo { x = 15; y = 16; }) (Foo { x = 17; y = 18; }) (Foo { x = 19; y = 20; }) (Foo { x = 21; y = 22; }) (Foo { x = 23; y = 24; }) (Foo { x = 25; y = 26; }), Bar { v = vec True False True; w = (True, 0xBEEF); z = Foo { x = 3; y = 4; } }) (vec (Foo { x = 27; y = 28; }) (Foo { x = 29; y = 30; }) (Foo { x = 31; y = 32; }) (Foo { x = 33; y = 34; }) (Foo { x = 35; y = 36; }) (Foo { x = 37; y = 38; }) (Foo { x = 39; y = 40; }) (Foo { x = 41; y = 42; }), Bar { v = vec True False True; w = (True, 0x4321); z = Foo { x = 123; y = 42; } }) (vec (Foo { x = 43; y = 44; }) (Foo { x = 45; y = 46; }) (Foo { x = 47; y = 48; }) (Foo { x = 49; y = 50; }) (Foo { x = 51; y = 52; }) (Foo { x = 53; y = 54; }) (Foo { x = 55; y = 56; }) (Foo { x = 57; y = 58; }), Bar { v = vec True True True; w = (True, 0xAABB); z = Foo { x = 3; y = 4; } }); d = (); e = nil; } - when i == 5 ==> $finish + when i == 5 ==> s.putZug $ DeepSplit $ Zug { qs = vec (Quix { q = 1; v = True }) (Quix { q = 2; v = False }); blob = False; } + when i == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/splitports.exp b/testsuite/bsc.verilog/splitports/splitports.exp index bf548ed20..8b49efecd 100644 --- a/testsuite/bsc.verilog/splitports/splitports.exp +++ b/testsuite/bsc.verilog/splitports/splitports.exp @@ -23,6 +23,7 @@ if { $vtest == 1 } { find_regexp mkDeepSplitTest.v {input \[16 : 0\] putBaz_1_a;} find_regexp mkDeepSplitTest.v {input \[7 : 0\] putBaz_1_c_2_1_7_y;} find_regexp mkDeepSplitTest.v {input \[15 : 0\] putBaz_1_c_2_2_w_2;} + find_regexp mkDeepSplitTest.v {input \[3 : 0\] putZug_1_qs_1;} } test_c_veri InstanceSplit diff --git a/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected b/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected index bb4f2dc03..fa26cd6e1 100644 --- a/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected +++ b/testsuite/bsc.verilog/splitports/sysDeepSplit.out.expected @@ -3,3 +3,4 @@ putBar: Bar {v=[True, False, True]; w=(True, 4660); z=Foo {x= 3; y= 4}} putFooBar: Foo {x= 5; y= 6} Bar {v=[False, True, False]; w=(False, 22136); z=Foo {x= 7; y= 8}} putFoos: [Foo {x= 9; y= 10}, Foo {x= 9; y= 10}, Foo {x= 10; y= 9}, Foo {x= 10; y= 8}, Foo {x= 11; y= 8}, Foo {x= 11; y= 7}, Foo {x= 12; y= 6}, Foo {x= 12; y= 6}, Foo {x= 13; y= 5}, Foo {x= 13; y= 4}, Foo {x= 14; y= 4}, Foo {x= 14; y= 3}, Foo {x= 15; y= 2}, Foo {x= 15; y= 2}, Foo {x= 16; y= 1}, Foo {x= 16; y= 0}, Foo {x= 17; y= 0}, Foo {x= 17; y= -1}, Foo {x= 18; y= -2}, Foo {x= 18; y= -2}, Foo {x= 19; y= -3}, Foo {x= 19; y= -4}, Foo {x= 20; y= -4}, Foo {x= 20; y= -5}, Foo {x= 21; y= -6}, Foo {x= 21; y= -6}, Foo {x= 22; y= -7}, Foo {x= 22; y= -8}, Foo {x= 23; y= -8}, Foo {x= 23; y= -9}, Foo {x= 24; y= -10}, Foo {x= 24; y= -10}, Foo {x= 25; y= -11}, Foo {x= 25; y= -12}, Foo {x= 26; y= -12}, Foo {x= 26; y= -13}, Foo {x= 27; y= -14}, Foo {x= 27; y= -14}, Foo {x= 28; y= -15}, Foo {x= 28; y= -16}, Foo {x= 29; y= -16}, Foo {x= 29; y= -17}, Foo {x= 30; y= -18}, Foo {x= 30; y= -18}, Foo {x= 31; y= -19}, Foo {x= 31; y= -20}, Foo {x= 32; y= -20}, Foo {x= 32; y= -21}, Foo {x= 33; y= -22}, Foo {x= 33; y= -22}] putBaz: Baz {a=Valid (Foo {x= 9; y= 10}); b=Bar {v=[True, False, False]; w=(True, 4660); z=Foo {x= 3; y= 4}}; c=[([Foo {x= 11; y= 12}, Foo {x= 13; y= 14}, Foo {x= 15; y= 16}, Foo {x= 17; y= 18}, Foo {x= 19; y= 20}, Foo {x= 21; y= 22}, Foo {x= 23; y= 24}, Foo {x= 25; y= 26}], Bar {v=[True, False, True]; w=(True, 48879); z=Foo {x= 3; y= 4}}), ([Foo {x= 27; y= 28}, Foo {x= 29; y= 30}, Foo {x= 31; y= 32}, Foo {x= 33; y= 34}, Foo {x= 35; y= 36}, Foo {x= 37; y= 38}, Foo {x= 39; y= 40}, Foo {x= 41; y= 42}], Bar {v=[True, False, True]; w=(True, 17185); z=Foo {x= 123; y= 42}}), ([Foo {x= 43; y= 44}, Foo {x= 45; y= 46}, Foo {x= 47; y= 48}, Foo {x= 49; y= 50}, Foo {x= 51; y= 52}, Foo {x= 53; y= 54}, Foo {x= 55; y= 56}, Foo {x= 57; y= 58}], Bar {v=[True, True, True]; w=(True, 43707); z=Foo {x= 3; y= 4}})]; d=(); e=[]} +putZug: Zug {qs=[Quix {q= 1; v=True}, Quix {q= 2; v=False}]; blob=False} From 150d29cc2dd7a75be1da5b6fb98885eefd8da9e0 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 19:10:02 -0700 Subject: [PATCH 32/43] Fix NoSplit instance --- src/Libraries/Base1/SplitPorts.bs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index 96e0c6ba8..e09f8e6a0 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -23,9 +23,9 @@ instance (DeepSplitPorts a p) => SplitPorts (DeepSplit a) p where portNames _ = deepSplitPortNames (_ :: a) instance DeepSplitPorts (NoSplit a) (Port a) where - splitPorts (NoSplit x) = Port x - unsplitPorts (Port x) = NoSplit x - portNames _ base = List.Cons base List.Nil + deepSplitPorts (NoSplit x) = Port x + deepUnsplitPorts (Port x) = NoSplit x + deepSplitPortNames _ base = Cons base Nil -- Helper class using generics, to split a struct or vector into a tuple of ports. From c8114b158627c65b3fdfa12902c53af9e657a4c0 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 19:34:09 -0700 Subject: [PATCH 33/43] Add a comment --- src/Libraries/Base1/Vector.bs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Libraries/Base1/Vector.bs b/src/Libraries/Base1/Vector.bs index 82a37d9cb..5ec178247 100644 --- a/src/Libraries/Base1/Vector.bs +++ b/src/Libraries/Base1/Vector.bs @@ -1256,7 +1256,7 @@ toChunks x = let padding = (0 :: Bit ch_sz) in unpack(tmp[v_sz-1:0]) - +-- Convert between a vector of n tuples a and a flattened tuple b. class ConcatTuple n a b | n a -> b where concatTuple :: Vector n a -> b unconcatTuple :: b -> Vector n a From 0ea992e85ae2852a9e204e5bae907c8bfbb3e07d Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 19:50:39 -0700 Subject: [PATCH 34/43] Stuff the field name in the WrapField type class as a type parameter for better error messages. --- src/Libraries/Base1/Prelude.bs | 62 ++++++++++--------- src/comp/ContextErrors.hs | 10 +-- src/comp/GenFuncWrap.hs | 7 ++- src/comp/GenWrap.hs | 22 ++++--- src/comp/GenWrapUtils.hs | 4 ++ ...ne_ArgNotInBits.bsv.bsc-vcomp-out.expected | 4 +- ...ne_ResNotInBits.bsv.bsc-vcomp-out.expected | 4 +- 7 files changed, 62 insertions(+), 51 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 464bde00a..349a60cd4 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4435,46 +4435,50 @@ data (MetaField :: $ -> # -> *) name idx = MetaField -- Should eventually include the output port names, when we support multiple output ports. primitive primMethod :: List String -> a -> a -class WrapField f w | f -> w where - -- Given the prefix and arg_names pragmas, converts a synthesized interface field value to - -- its wrapper interface field. - toWrapField :: String -> List String -> f -> w - - -- Converts a wrapper interface field value to its synthesized interface field. - fromWrapField :: w -> f +-- Convert bewtween a field in an interface that is being synthesized, +-- and a field in the corresponding field in the generated wrapper interface. +-- Also takes the name of the field for error reporting purposes. +class (WrapField :: $ -> * -> * -> *) name f w | name f -> w where + -- Given a proxy value for the field name, and the values of the prefix and arg_names pragmas, + -- converts a synthesized interface field value to its wrapper interface field. + toWrapField :: StrArg name -> String -> List String -> f -> w + + -- Given a proxy value for the field name, converts a wrapper interface field value + -- to its synthesized interface field. + fromWrapField :: StrArg name -> w -> f -- Save the port types for a field in the wrapped interface, given the module name -- and the prefix, arg_names and result pragmas. - saveFieldPortTypes :: f -> Maybe Name__ -> String -> List String -> String -> Module () - saveFieldPortTypes _ _ _ _ _ = return () + saveFieldPortTypes :: StrArg name -> f -> Maybe Name__ -> String -> List String -> String -> Module () + saveFieldPortTypes _ _ _ _ _ _ = return () -instance (WrapMethod m w) => (WrapField m w) where - toWrapField prefix names = +instance (WrapMethod m w) => (WrapField name m w) where + toWrapField _ prefix names = let baseNames = methodArgBaseNames (_ :: m) prefix names 1 in primMethod (inputPortNames (_ :: m) baseNames) ∘ toWrapMethod - fromWrapField = fromWrapMethod - saveFieldPortTypes _ modName prefix names = + fromWrapField _ = fromWrapMethod + saveFieldPortTypes _ _ modName prefix names = let baseNames = methodArgBaseNames (_ :: m) prefix names 1 in saveMethodPortTypes (_ :: m) modName baseNames -- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface, -- but this case was being handled in GenWrap. -instance WrapField PrimAction PrimAction where - toWrapField _ _ = id - fromWrapField = id - -instance WrapField Clock Clock where - toWrapField _ _ = id - fromWrapField = id - -instance WrapField Reset Reset where - toWrapField _ _ = id - fromWrapField = id - -instance (Bits a n) => WrapField (Inout a) (Inout_ n) where - toWrapField _ _ = primInoutCast0 - fromWrapField = primInoutUncast0 - saveFieldPortTypes _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: (Inout a)) +instance WrapField name PrimAction PrimAction where + toWrapField _ _ _ = id + fromWrapField _ = id + +instance WrapField name Clock Clock where + toWrapField _ _ _ = id + fromWrapField _ = id + +instance WrapField name Reset Reset where + toWrapField _ _ _ = id + fromWrapField _ = id + +instance (Bits a n) => WrapField name (Inout a) (Inout_ n) where + toWrapField _ _ _ = primInoutCast0 + fromWrapField _ = primInoutUncast0 + saveFieldPortTypes _ _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: (Inout a)) class WrapMethod m w | m -> w where -- Convert a synthesized interface method to its wrapper interface method. diff --git a/src/comp/ContextErrors.hs b/src/comp/ContextErrors.hs index 63e5cc555..0519ee94c 100644 --- a/src/comp/ContextErrors.hs +++ b/src/comp/ContextErrors.hs @@ -20,7 +20,7 @@ import TIMonad import TCMisc import Unify -import FStringCompat (mkFString) +import FStringCompat (FString, mkFString, getFString) import Id(mkId) import PreIds import CSyntax @@ -167,7 +167,7 @@ handleContextReduction' pos "SizedLiteral instance contains wrong number of types") | cid == idWrapField = case ts of - [t, _] -> return $ handleCtxRedWrapField pos p t + [TCon (TyStr name _), t, _] -> return $ handleCtxRedWrapField pos p name t _ -> internalError("handleContextReduction': " ++ "WrapField instance contains wrong number of types") @@ -461,9 +461,9 @@ handleCtxRedPrimPort pos (vp, reduced_ps) userty = -- -------------------- -handleCtxRedWrapField:: Position -> (VPred, [VPred]) -> Type -> EMsg -handleCtxRedWrapField pos (vp, reduced_ps) userty = - (pos, EBadIfcType (pfpString userty) -- XXX reporting the type, no easy way to get the method name here. +handleCtxRedWrapField:: Position -> (VPred, [VPred]) -> FString -> Type -> EMsg +handleCtxRedWrapField pos (vp, reduced_ps) name userty = + (pos, EBadIfcType (getFString name) "This method uses types that are not in the Bits or SplitPorts typeclass.") diff --git a/src/comp/GenFuncWrap.hs b/src/comp/GenFuncWrap.hs index ef173c822..6a94d95fe 100644 --- a/src/comp/GenFuncWrap.hs +++ b/src/comp/GenFuncWrap.hs @@ -9,13 +9,13 @@ import Error(internalError, ErrMsg(..), ErrorHandle, bsError) import Flags(Flags) import PPrint import Id -import PreIds(id_fromWrapField, idActionValue) +import PreIds(id_fromWrapField, idActionValue, idStrArg) import CSyntax import SymTab import Scheme import Assump import Type(tModule, fn) -import CType(getArrows, getRes) +import CType(getArrows, getRes, cTStr) import Pred(expandSyn) import TypeCheck(cCtxReduceDef) import Subst(tv) @@ -246,7 +246,8 @@ funcDef errh symt i oqt@(CQType _ ot) i_ n (CQType _ t) = -- the result is either an actionvalue or a value isAV = isActionValue symt r - expr = cVApply id_fromWrapField [CVar i_] + fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString i) (getIdPosition i) + expr = cVApply id_fromWrapField [fnp, CVar i_] in -- XXX this code works for Action/ActionValue foreign funcs, -- XXX but they are not handled by astate yet diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 374acd5bc..f2a842ad4 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -25,7 +25,6 @@ import IdPrint import PreIds import CSyntax import CSyntaxUtil -import Undefined (UndefKind(..)) import SymTab(SymTab, TypeInfo(..), FieldInfo(..), findType, addTypesUQ, findField, findFieldInfo, getMethodArgNames) import MakeSymTab(convCQType) @@ -901,8 +900,9 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = let (fields,props) = unzip fieldsprops return (concat fields, concat props) _ -> do -- ELSE NOT a Vec + let fnt = cTStr (getIdFString fieldIdQ) (getIdPosition fieldIdQ) let v = cTVar $ head tmpTyVarIds - let ctx = CPred (CTypeclass idWrapField) [foldr arrow rettype argtypes, v] + let ctx = CPred (CTypeclass idWrapField) [fnt, foldr arrow rettype argtypes, v] let fi = binId prefixes fieldId -- @@ -1107,9 +1107,10 @@ genTo pps ty mk = localPrefix = joinStrings_ currentPre localPrefix1 prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] + fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) -- XXX idEmpty is a horrible way to know no more selection is required let ec = if f == idEmpty then sel else CSelect sel (setInternal f) - let e = CApply (CVar id_toWrapField) [prefix, arg_names, ec] + let e = CApply (CVar id_toWrapField) [fnp, prefix, arg_names, ec] return [CLValue (binId prefixes f) [CClause [] [] e] []] -- -------------------- @@ -1199,7 +1200,9 @@ genFrom pps ty var = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let e = CApply (CVar id_fromWrapField) [sel binf] + + let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + let e = CApply (CVar id_fromWrapField) [fnp, sel binf] return (f, e, qs) @@ -1611,7 +1614,8 @@ mkFromBind true_ifc_ids var ft = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (wbinf `elem` true_ifc_ids || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let e = CApply (CVar id_fromWrapField) [sel binf] + let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + let e = CApply (CVar id_fromWrapField) [fnp, sel binf] return (f, e, qs) @@ -2170,7 +2174,8 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes ifcId Just str -> joinStrings_ currentPre str Nothing -> joinStrings_ currentPre methodStr - let proxy = mkProxy $ foldr arrow r as + let fproxy = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + proxy = mkProxy $ foldr arrow r as prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] result = stringLiteralAt noPosition resultName @@ -2178,7 +2183,7 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes ifcId CSExpr Nothing $ cVApply idLiftModule $ [cVApply id_saveFieldPortTypes - [proxy, mkMaybe v, prefix, arg_names, result]]] + [fproxy, proxy, mkMaybe v, prefix, arg_names, result]]] saveNameStmt :: Id -> Id -> CMStmt @@ -2220,9 +2225,6 @@ tmod t = TAp (cTCon idModule) t id_t :: Position -> Id id_t pos = mkId pos fs_t -mkProxy :: CType -> CExpr -mkProxy ty = CHasType (CAny (getPosition ty) UNotUsed) $ CQType [] ty - -- ==================== -- Ready method utilities diff --git a/src/comp/GenWrapUtils.hs b/src/comp/GenWrapUtils.hs index eef8e628b..d8c6fe8f7 100644 --- a/src/comp/GenWrapUtils.hs +++ b/src/comp/GenWrapUtils.hs @@ -9,6 +9,7 @@ import Pragma import PreIds import CSyntax import CType +import Undefined (UndefKind(..)) -- ==================== @@ -87,4 +88,7 @@ getDefArgs dcls t = -- ==================== +mkProxy :: CType -> CExpr +mkProxy ty = CHasType (CAny (getPosition ty) UNotUsed) $ CQType [] ty + diff --git a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected index 6e1dd0aba..8cb78a0bb 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected @@ -7,5 +7,5 @@ Error: Unknown position: (T0031) The proviso was implied by expressions at the following positions: "NoInline_ArgNotInBits.bsv", line 4, column 15 Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0043) - Cannot synthesize `function Bool f(NoInline_ArgNotInBits::L x1)': This - method uses types that are not in the Bits or SplitPorts typeclass. + Cannot synthesize `fnNoInline_ArgNotInBits': This method uses types that are + not in the Bits or SplitPorts typeclass. diff --git a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected index be21fcb36..f00649d96 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected @@ -7,8 +7,8 @@ Error: Unknown position: (T0031) The proviso was implied by expressions at the following positions: "NoInline_ResNotInBits.bsv", line 4, column 12 Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0043) - Cannot synthesize `function NoInline_ResNotInBits::L f(Bool x1)': This - method uses types that are not in the Bits or SplitPorts typeclass. + Cannot synthesize `fnNoInline_ResNotInBits': This method uses types that are + not in the Bits or SplitPorts typeclass. Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0029) Signature mismatch (given too general): given: From 9d7921fd747c8c4b9567dfe7bc232ad805e5d43a Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Mon, 19 Aug 2024 22:26:11 -0700 Subject: [PATCH 35/43] Fix trailing whitespace --- src/Libraries/Base1/Vector.bs | 2 +- src/comp/IExpandUtils.hs | 4 ++-- src/comp/PragmaCheck.hs | 2 +- testsuite/bsc.verilog/splitports/DeepSplit.bs | 2 +- testsuite/bsc.verilog/splitports/InstanceSplit.bs | 2 +- testsuite/bsc.verilog/splitports/ShallowSplit.bs | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Libraries/Base1/Vector.bs b/src/Libraries/Base1/Vector.bs index 5ec178247..e329ae57b 100644 --- a/src/Libraries/Base1/Vector.bs +++ b/src/Libraries/Base1/Vector.bs @@ -1302,7 +1302,7 @@ instance (Add n1 1 n, ConcatTuple' n1 a b, AppendTuple b b c) => ConcatTuple' n let v1 :: Vector (TExp n1) a = take v v2 :: Vector (TExp n1) a = drop v in concatTuple' v1 `appendTuple` concatTuple' v2 - unconcatTuple' x = + unconcatTuple' x = let res :: (b, b) = splitTuple x v1 :: Vector (TExp n1) a = unconcatTuple' res.fst v2 :: Vector (TExp n1) a = unconcatTuple' res.snd diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index 53de081f7..5c64ce636 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -2016,7 +2016,7 @@ chkIfcPortNames errh args ifcs (ClockInfo ci co _ _) (ResetInfo ri ro) = when (not (null emsgs)) $ bsError errh emsgs where input_clock_ports i = - case lookup i ci of + case lookup i ci of Just (Just (VName o, Right (VName g))) -> [o, g] Just (Just (VName o, Left _)) -> [o] _ -> [] @@ -2041,7 +2041,7 @@ chkIfcPortNames errh args ifcs (ClockInfo ci co _ _) (ResetInfo ri ro) = default_clock_names = [ (n, idDefaultClock) | n <- input_clock_ports idDefaultClock ] default_reset_names = [ (n, idDefaultReset) | n <- input_reset_ports idDefaultReset ] - + arg_names = sort $ arg_port_names ++ arg_inout_names ++ arg_clock_names ++ arg_reset_names ++ default_clock_names ++ default_reset_names diff --git a/src/comp/PragmaCheck.hs b/src/comp/PragmaCheck.hs index d8c5a30c3..bd7701396 100644 --- a/src/comp/PragmaCheck.hs +++ b/src/comp/PragmaCheck.hs @@ -557,7 +557,7 @@ checkModulePortNames flgs pos pps vtis ftps = isClkField (_,t,_) = t == tClock isRstField (_,t,_) = t == tReset - + (clk_fs, other_fs) = partition isClkField ftps (rst_fs, _) = partition isRstField other_fs diff --git a/testsuite/bsc.verilog/splitports/DeepSplit.bs b/testsuite/bsc.verilog/splitports/DeepSplit.bs index 5b9eb8c2d..9cab5afea 100644 --- a/testsuite/bsc.verilog/splitports/DeepSplit.bs +++ b/testsuite/bsc.verilog/splitports/DeepSplit.bs @@ -50,7 +50,7 @@ interface SplitTest = {-# synthesize mkDeepSplitTest #-} mkDeepSplitTest :: Module SplitTest -mkDeepSplitTest = +mkDeepSplitTest = module interface putFoo (DeepSplit x) = $display "putFoo: " (cshow x) diff --git a/testsuite/bsc.verilog/splitports/InstanceSplit.bs b/testsuite/bsc.verilog/splitports/InstanceSplit.bs index 1e6a71314..83c2ce7da 100644 --- a/testsuite/bsc.verilog/splitports/InstanceSplit.bs +++ b/testsuite/bsc.verilog/splitports/InstanceSplit.bs @@ -51,7 +51,7 @@ interface SplitTest = {-# synthesize mkInstanceSplitTest #-} mkInstanceSplitTest :: Module SplitTest -mkInstanceSplitTest = +mkInstanceSplitTest = module interface putFoo x = $display "putFoo: " (cshow x) diff --git a/testsuite/bsc.verilog/splitports/ShallowSplit.bs b/testsuite/bsc.verilog/splitports/ShallowSplit.bs index 11166e76a..1c96ac47b 100644 --- a/testsuite/bsc.verilog/splitports/ShallowSplit.bs +++ b/testsuite/bsc.verilog/splitports/ShallowSplit.bs @@ -34,7 +34,7 @@ interface SplitTest = {-# synthesize mkShallowSplitTest #-} mkShallowSplitTest :: Module SplitTest -mkShallowSplitTest = +mkShallowSplitTest = module interface putFoo (ShallowSplit x) = $display "putFoo: " (cshow x) From f0d8ac7739066940f23076276a795166410f3809 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Tue, 20 Aug 2024 12:28:53 -0700 Subject: [PATCH 36/43] Addressing Ravi's comments --- src/Libraries/Base1/Prelude.bs | 11 ++++++++--- src/Libraries/Base1/SplitPorts.bs | 12 +++++++----- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 349a60cd4..0bae79591 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -4450,7 +4450,6 @@ class (WrapField :: $ -> * -> * -> *) name f w | name f -> w where -- Save the port types for a field in the wrapped interface, given the module name -- and the prefix, arg_names and result pragmas. saveFieldPortTypes :: StrArg name -> f -> Maybe Name__ -> String -> List String -> String -> Module () - saveFieldPortTypes _ _ _ _ _ _ = return () instance (WrapMethod m w) => (WrapField name m w) where toWrapField _ prefix names = @@ -4466,14 +4465,17 @@ instance (WrapMethod m w) => (WrapField name m w) where instance WrapField name PrimAction PrimAction where toWrapField _ _ _ = id fromWrapField _ = id + saveFieldPortTypes _ _ _ _ _ _ = return () instance WrapField name Clock Clock where toWrapField _ _ _ = id fromWrapField _ = id + saveFieldPortTypes _ _ _ _ _ _ = return () instance WrapField name Reset Reset where toWrapField _ _ _ = id fromWrapField _ = id + saveFieldPortTypes _ _ _ _ _ _ = return () instance (Bits a n) => WrapField name (Inout a) (Inout_ n) where toWrapField _ _ _ = primInoutCast0 @@ -4489,11 +4491,9 @@ class WrapMethod m w | m -> w where -- Compute the actual argument base names for a method, given the prefix and arg_names pragmas. methodArgBaseNames :: m -> String -> List String -> Integer -> List String - methodArgBaseNames _ _ _ _ = Nil -- Compute the list of input port names for a method, from the argument base names. inputPortNames :: m -> List String -> List String - inputPortNames _ _ = Nil -- Save the port types for a method, given the module name, argument base names and result name. saveMethodPortTypes :: m -> Maybe Name__ -> List String -> String -> Module () @@ -4504,6 +4504,7 @@ instance (SplitPorts a p, TupleSize p n, WrapPorts p pb, WrapMethod b v, Curry ( fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ packPorts ∘ splitPorts methodArgBaseNames _ prefix (Cons h t) i = Cons + -- arg_names can start with a digit (if prefix == "" && not (isDigit $ stringHead h) then h else prefix +++ "_" +++ h) (methodArgBaseNames (_ :: b) prefix t $ i + 1) methodArgBaseNames _ prefix Nil i = Cons @@ -4521,11 +4522,15 @@ instance (SplitPorts a p, TupleSize p n, WrapPorts p pb, WrapMethod b v, Curry ( instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where toWrapMethod = toActionValue_ fromWrapMethod = fromActionValue_ + methodArgBaseNames _ _ _ _ = Nil + inputPortNames _ _ = Nil saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a) instance (Bits a n) => WrapMethod a (Bit n) where toWrapMethod = pack fromWrapMethod = unpack + methodArgBaseNames _ _ _ _ = Nil + inputPortNames _ _ = Nil saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a) {- diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index e09f8e6a0..57aeafb8e 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -68,6 +68,7 @@ instance (ShallowSplitPorts' r p) => ShallowSplitPorts' (Meta (MetaField name id shallowSplitPorts' (Meta x) = shallowSplitPorts' x shallowUnsplitPorts' = Meta ∘ shallowUnsplitPorts' shallowSplitPortNames' _ base = shallowSplitPortNames' (_ :: r) $ + -- Avoid an extra underscore, since data fields names are _[0-9]+ if stringHead (stringOf name) == '_' then base +++ stringOf name else base +++ "_" +++ stringOf name @@ -106,25 +107,25 @@ instance DeepSplitPorts () () where instance (DeepSplitTuplePorts (a, b) p) => DeepSplitPorts (a, b) p where deepSplitPorts = deepSplitTuplePorts - deepUnsplitPorts = deepUndeepSplitTuplePorts + deepUnsplitPorts = deepUnsplitTuplePorts deepSplitPortNames = deepSplitTuplePortNames 1 class DeepSplitTuplePorts a p | a -> p where deepSplitTuplePorts :: a -> p - deepUndeepSplitTuplePorts :: p -> a + deepUnsplitTuplePorts :: p -> a deepSplitTuplePortNames :: Integer -> a -> String -> List String instance (DeepSplitPorts a p, DeepSplitTuplePorts b q, AppendTuple p q r) => DeepSplitTuplePorts (a, b) r where deepSplitTuplePorts (a, b) = deepSplitPorts a `appendTuple` deepSplitTuplePorts b - deepUndeepSplitTuplePorts x = case splitTuple x of - (a, b) -> (deepUnsplitPorts a, deepUndeepSplitTuplePorts b) + deepUnsplitTuplePorts x = case splitTuple x of + (a, b) -> (deepUnsplitPorts a, deepUnsplitTuplePorts b) deepSplitTuplePortNames i _ base = deepSplitPortNames (_ :: a) (base +++ "_" +++ integerToString i) `List.append` deepSplitTuplePortNames (i + 1) (_ :: b) base instance (DeepSplitPorts a p) => DeepSplitTuplePorts a p where deepSplitTuplePorts = deepSplitPorts - deepUndeepSplitTuplePorts x = deepUnsplitPorts x + deepUnsplitTuplePorts x = deepUnsplitPorts x deepSplitTuplePortNames i _ base = deepSplitPortNames (_ :: a) $ base +++ "_" +++ integerToString i @@ -178,6 +179,7 @@ instance (DeepSplitPorts'' r p) => DeepSplitPorts'' (Meta (MetaField name idx) r deepSplitPorts'' (Meta x) = deepSplitPorts'' x deepUnsplitPorts'' = Meta ∘ deepUnsplitPorts'' deepSplitPortNames'' _ base = deepSplitPortNames'' (_ :: r) $ + -- Avoid an extra underscore, since data fields names are _[0-9]+ if stringHead (stringOf name) == '_' then base +++ stringOf name else base +++ "_" +++ stringOf name From 7067fbe4c8ed8d9167ffa4169dc6079974042dba Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Tue, 20 Aug 2024 17:02:31 -0700 Subject: [PATCH 37/43] Fix more comments --- src/comp/CVPrint.hs | 4 ++-- src/comp/ContextErrors.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/comp/CVPrint.hs b/src/comp/CVPrint.hs index 100b93685..f2c8c95d6 100644 --- a/src/comp/CVPrint.hs +++ b/src/comp/CVPrint.hs @@ -287,8 +287,8 @@ instance PVPrint CDefn where pvPrint d p (CprimType (IdKind i k)) = t"primitive type" <+> pp d i <+> t "::" <+> pp d k - pvPrint d p (Cforeign i ty oname opnames _) = - text "foreign" <+> pvpId d i <+> t "::" + pvPrint d p (Cforeign i ty oname opnames ni) = + text "foreign" <> (if ni then text " noinline" else empty) <+> pvpId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> empty; Just s -> text (" = " ++ show s)) <> (case opnames of diff --git a/src/comp/ContextErrors.hs b/src/comp/ContextErrors.hs index 0519ee94c..824a6a77f 100644 --- a/src/comp/ContextErrors.hs +++ b/src/comp/ContextErrors.hs @@ -464,7 +464,7 @@ handleCtxRedPrimPort pos (vp, reduced_ps) userty = handleCtxRedWrapField:: Position -> (VPred, [VPred]) -> FString -> Type -> EMsg handleCtxRedWrapField pos (vp, reduced_ps) name userty = (pos, EBadIfcType (getFString name) - "This method uses types that are not in the Bits or SplitPorts typeclass.") + "This method uses types that are not in the Bits or SplitPorts typeclasses.") -- ======================================================================== From 0e23ad04ba6fa3a5ac4bad004094a7357b44d01f Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 22 Aug 2024 11:11:01 -0700 Subject: [PATCH 38/43] Fix testsuite failure after error message tweak --- .../noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected | 2 +- .../noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected index 8cb78a0bb..e274d2a83 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ArgNotInBits.bsv.bsc-vcomp-out.expected @@ -8,4 +8,4 @@ Error: Unknown position: (T0031) "NoInline_ArgNotInBits.bsv", line 4, column 15 Error: "NoInline_ArgNotInBits.bsv", line 4, column 15: (T0043) Cannot synthesize `fnNoInline_ArgNotInBits': This method uses types that are - not in the Bits or SplitPorts typeclass. + not in the Bits or SplitPorts typeclasses. diff --git a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected index f00649d96..66f5ca699 100644 --- a/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.verilog/noinline/NoInline_ResNotInBits.bsv.bsc-vcomp-out.expected @@ -8,7 +8,7 @@ Error: Unknown position: (T0031) "NoInline_ResNotInBits.bsv", line 4, column 12 Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0043) Cannot synthesize `fnNoInline_ResNotInBits': This method uses types that are - not in the Bits or SplitPorts typeclass. + not in the Bits or SplitPorts typeclasses. Error: "NoInline_ResNotInBits.bsv", line 4, column 12: (T0029) Signature mismatch (given too general): given: From 132953449d3d376663b0e4de4d1124f083b7d047 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 22 Aug 2024 16:03:25 -0700 Subject: [PATCH 39/43] Record the full field name path in WrapField context, for better errors for a non-synthesizable subinterface --- src/comp/GenWrap.hs | 20 +++++++++++++------ .../signature/NestedIfcIntegerArg.bs | 14 +++++++++++++ testsuite/bsc.codegen/signature/signature.exp | 1 + 3 files changed, 29 insertions(+), 6 deletions(-) create mode 100644 testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index f2a842ad4..1aeadcd89 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -19,7 +19,7 @@ import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), ErrorHandle, bsError) import ErrorMonad(ErrorMonad, convErrorMonadToIO) import Flags(Flags) import FStringCompat -import PreStrings(fsUnderscore, fs_t, fsTo, fsFrom, fsEmpty, fsEnable, fs_rdy) +import PreStrings(fsUnderscore, fs_t, fsTo, fsFrom, fsEmpty, fsEnable, fs_rdy, fsDot) import Id import IdPrint import PreIds @@ -900,7 +900,7 @@ genIfcField trec ifcIdIn prefixes (FInf fieldIdQ argtypes rettype _) = let (fields,props) = unzip fieldsprops return (concat fields, concat props) _ -> do -- ELSE NOT a Vec - let fnt = cTStr (getIdFString fieldIdQ) (getIdPosition fieldIdQ) + let fnt = cTStr (fieldPathName prefixes fieldId) (getIdPosition fieldIdQ) let v = cTVar $ head tmpTyVarIds let ctx = CPred (CTypeclass idWrapField) [fnt, foldr arrow rettype argtypes, v] @@ -1107,7 +1107,7 @@ genTo pps ty mk = localPrefix = joinStrings_ currentPre localPrefix1 prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] - fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (fieldPathName prefixes f)(getIdPosition f) -- XXX idEmpty is a horrible way to know no more selection is required let ec = if f == idEmpty then sel else CSelect sel (setInternal f) let e = CApply (CVar id_toWrapField) [fnp, prefix, arg_names, ec] @@ -1201,7 +1201,7 @@ genFrom pps ty var = let qs = if (hasNoRdy || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (fieldPathName prefixes f) (getIdPosition f) let e = CApply (CVar id_fromWrapField) [fnp, sel binf] return (f, e, qs) @@ -1614,7 +1614,7 @@ mkFromBind true_ifc_ids var ft = let meth_guard = CApply eUnpack [sel wbinf] let qs = if (wbinf `elem` true_ifc_ids || isClock || isReset || isIot) then [] else [CQFilter meth_guard] - let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + let fnp = mkProxy $ TAp (cTCon idStrArg) $ cTStr (fieldPathName prefixes f) (getIdPosition f) let e = CApply (CVar id_fromWrapField) [fnp, sel binf] return (f, e, qs) @@ -1930,6 +1930,14 @@ binId :: IfcPrefixes -> Id -> Id binId ifcp i | i == idEmpty = mkId noPosition (concatFString (init (ifcp_pathIdString ifcp))) binId ifcp i = (mkIdPre (concatFString (ifcp_pathIdString ifcp)) (unQualId i)) +fieldPathName :: IfcPrefixes -> Id -> FString +-- XXX horrible hack when there isn't selection required at the end +fieldPathName ifcp i | i == idEmpty = concatFString $ init $ map underscoreToDot $ ifcp_pathIdString ifcp +fieldPathName ifcp i = concatFString $ map underscoreToDot (ifcp_pathIdString ifcp) ++ [getIdBase i] + +underscoreToDot :: FString -> FString +underscoreToDot fs = if fs == fsUnderscore then fsDot else fs + -- Extend the prefixes -- Take the current set of prefix information, add to that information -- from the the pragma of the current field Id, and add it to the current set of @@ -2174,7 +2182,7 @@ mkFieldSavePortTypeStmts v ifcId = concatMapM $ meth noPrefixes ifcId Just str -> joinStrings_ currentPre str Nothing -> joinStrings_ currentPre methodStr - let fproxy = mkProxy $ TAp (cTCon idStrArg) $ cTStr (getIdFString f) (getIdPosition f) + let fproxy = mkProxy $ TAp (cTCon idStrArg) $ cTStr (fieldPathName prefixes f) (getIdPosition f) proxy = mkProxy $ foldr arrow r as prefix = stringLiteralAt noPosition localPrefix arg_names = mkList [stringLiteralAt (getPosition i) (getIdString i) | i <- aIds] diff --git a/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs b/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs new file mode 100644 index 000000000..0c8072713 --- /dev/null +++ b/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs @@ -0,0 +1,14 @@ +package NestedIfcIntegerArg where + +interface Foo = + put :: Integer -> Action + +interface Bar = + f :: Foo + +{-# synthesize mkBar #-} +mkBar :: Module Bar +mkBar = module + interface + f = interface Foo + put _ = noAction \ No newline at end of file diff --git a/testsuite/bsc.codegen/signature/signature.exp b/testsuite/bsc.codegen/signature/signature.exp index f560b908f..e33bf0603 100644 --- a/testsuite/bsc.codegen/signature/signature.exp +++ b/testsuite/bsc.codegen/signature/signature.exp @@ -10,6 +10,7 @@ compile_verilog_fail_error ProvisoMethod.bsv T0043 compile_verilog_fail_error NonBitsModuleArg.bsv T0043 compile_verilog_fail_error NonIfc.bsv T0043 compile_verilog_fail_error NonModule.bsv T0043 1 sysNonModule +compile_verilog_fail_error NestedIfcIntegerArg.bs T0043 # Test that types which are not simple constructors (but have arguments) # are also handled From 6f8c504de991d0b4697b98eb6eec1e6b8bfcddad Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 22 Aug 2024 16:29:54 -0700 Subject: [PATCH 40/43] Don't surface implicit conditions from inside ICMethod --- src/comp/IExpand.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 1b5c32e37..98d614472 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -4105,10 +4105,6 @@ getBuriedPreds (IAps ic@(ICon i_sel (ICSel { })) ts1 [e]) | (i_sel == idAVValue_ || i_sel == idAVAction_) = do --traceM("getBuriedPreds: AV sel") getBuriedPreds e -getBuriedPreds (ICon _ (ICMethod _ _ eb)) = do - -- traceM("getBuriedPreds: method") - p <- getBuriedPreds eb - return p getBuriedPreds e@(ICon _ _) = do --traceM("getBuriedPreds: con: e = " ++ ppReadable e ++ show e) return pTrue From b1165c94b2f3e4d8eff612a734eb1e8c3eeebd62 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Thu, 22 Aug 2024 17:02:57 -0700 Subject: [PATCH 41/43] FIx trailing whitespace --- testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs b/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs index 0c8072713..8ae222666 100644 --- a/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs +++ b/testsuite/bsc.codegen/signature/NestedIfcIntegerArg.bs @@ -1,9 +1,9 @@ package NestedIfcIntegerArg where -interface Foo = +interface Foo = put :: Integer -> Action -interface Bar = +interface Bar = f :: Foo {-# synthesize mkBar #-} From 0868d7949b3f4b19c1992988da387bfa1e160bb8 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 23 Aug 2024 11:48:03 -0700 Subject: [PATCH 42/43] Slightly less gross list deconstruction in IExpand --- src/comp/IExpand.hs | 23 ++++++++++++----------- src/comp/PreIds.hs | 3 ++- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 98d614472..53be85609 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -2117,17 +2117,18 @@ evalStringList :: HExpr -> G ([String], Position) evalStringList e = do e' <- evaleUH e case e' of - IAps (ICon _ c) _ [a] -> do - a' <- evaleUH a - -- XXX this is a horrible way of pulling apart a list, but I don't think there is a better way: - case a' of - IAps (ICon i' (ICTuple {})) _ [e_h, e_t] | getIdBaseString i' == "List_$Cons" -> do - (h, _) <- evalString e_h - (t, _) <- evalStringList e_t - return (h:t, getIExprPosition e') - ICon _ (ICInt _ (IntLit { ilValue = 0 })) -> - return ([], getIExprPosition e') - _ -> internalError ("evalStringList con: " ++ showTypeless a') + IAps (ICon i _) _ [a] -> + if i == idPreludeCons then do + a' <- evaleUH a + case a' of + IAps (ICon _ (ICTuple {})) _ [e_h, e_t] -> do + (h, _) <- evalString e_h + (t, _) <- evalStringList e_t + return (h:t, getIExprPosition e') + _ -> internalError ("evalStringList Cons: " ++ showTypeless a') + -- We get primChr for Nil, since it's a no-argument constructor + else if i == idPrimChr then return ([], getIExprPosition e') + else internalError ("evalStringList con: " ++ show i) _ -> do e'' <- unheapAll e' errG (getIExprPosition e', EStringListNF (ppString e')) diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index 24091731f..803f7fe12 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -118,10 +118,11 @@ idInvalid = prelude_id_no fsInvalid idValid = prelude_id_no fsValid idEmpty = prelude_id_no fsEmptyIfc idFile = prelude_id_no fsFile -idEither, idLeft, idRight :: Id +idEither, idLeft, idRight, idPreludeCons :: Id idEither = prelude_id_no fsEither idLeft = prelude_id_no fsLeft idRight = prelude_id_no fsRight +idPreludeCons = prelude_id_no fsCons -- idCons isn't qualified idActionValue :: Id idActionValue = prelude_id_no fsActionValue From df0f863a76e01698fa265d80c38fda5e17c53966 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 23 Aug 2024 12:31:46 -0700 Subject: [PATCH 43/43] Add more tests --- .../ArgNamesPragma_PortNameConflict.bs | 25 ++++++++++ ...PortNameConflict.bs.bsc-vcomp-out.expected | 7 +++ .../BadSplitInst_PortNameConflict.bs | 25 ++++++++++ ...PortNameConflict.bs.bsc-vcomp-out.expected | 7 +++ .../BadSplitInst_TooManyPortNames.bs | 24 ++++++++++ ...TooManyPortNames.bs.bsc-vcomp-out.expected | 8 ++++ .../splitports/PortNameConflict.bs | 34 ++++++++++++++ ...PortNameConflict.bs.bsc-vcomp-out.expected | 7 +++ .../bsc.verilog/splitports/SomeArgNames.bs | 46 +++++++++++++++++++ .../bsc.verilog/splitports/splitports.exp | 23 +++++++++- .../splitports/sysSomeArgNames.out.expected | 1 + 11 files changed, 206 insertions(+), 1 deletion(-) create mode 100644 testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs create mode 100644 testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs.bsc-vcomp-out.expected create mode 100644 testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs create mode 100644 testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs.bsc-vcomp-out.expected create mode 100644 testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs create mode 100644 testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs.bsc-vcomp-out.expected create mode 100644 testsuite/bsc.verilog/splitports/PortNameConflict.bs create mode 100644 testsuite/bsc.verilog/splitports/PortNameConflict.bs.bsc-vcomp-out.expected create mode 100644 testsuite/bsc.verilog/splitports/SomeArgNames.bs create mode 100644 testsuite/bsc.verilog/splitports/sysSomeArgNames.out.expected diff --git a/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs b/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs new file mode 100644 index 000000000..85046dab3 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs @@ -0,0 +1,25 @@ +package ArgNamesPragma_PortNameConflict where + +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + z :: Bool + deriving (Bits) + +instance SplitPorts Foo (Port (Int 8), Port (Int 8), Port Bool) where + splitPorts f = (Port f.x, Port f.y, Port f.z) + unsplitPorts (Port x, Port y, Port z) = Foo { x=x; y=y; z=z; } + portNames _ base = Cons (base +++ "_x") $ Cons (base +++ "_y") $ Cons (base +++ "_z") Nil + +interface SplitTest = + putFoo :: Foo -> Bool -> Action {-# prefix = "fooIn", arg_names = ["f", "f_z"] #-} + +{-# synthesize sysArgNamesPragma_PortNameConflict #-} +sysArgNamesPragma_PortNameConflict :: Module SplitTest +sysArgNamesPragma_PortNameConflict = + module + interface + putFoo x y = $display "putFoo: " (cshow x) (cshow y) diff --git a/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs.bsc-vcomp-out.expected b/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs.bsc-vcomp-out.expected new file mode 100644 index 000000000..37bd887de --- /dev/null +++ b/testsuite/bsc.verilog/splitports/ArgNamesPragma_PortNameConflict.bs.bsc-vcomp-out.expected @@ -0,0 +1,7 @@ +checking package dependencies +compiling ArgNamesPragma_PortNameConflict.bs +code generation for sysArgNamesPragma_PortNameConflict starts +Error: "ArgNamesPragma_PortNameConflict.bs", line 21, column 0: (G0055) + Method `putFoo' generates a port with name `fooIn_f_z' which conflicts with + a port of the same name generated by method `putFoo' at location + "ArgNamesPragma_PortNameConflict.bs", line 21, column 0. diff --git a/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs b/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs new file mode 100644 index 000000000..8fc5d1518 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs @@ -0,0 +1,25 @@ +package BadSplitInst_PortNameConflict where + +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + z :: Bool + deriving (Bits) + +instance SplitPorts Foo (Port (Int 8), Port (Int 8), Port Bool) where + splitPorts f = (Port f.x, Port f.y, Port f.z) + unsplitPorts (Port x, Port y, Port z) = Foo { x=x; y=y; z=z; } + portNames _ base = Cons (base +++ "_x") $ Cons (base +++ "_y") $ Cons (base +++ "_x") Nil + +interface SplitTest = + putFoo :: Foo -> Action {-# prefix = "fooIn" #-} + +{-# synthesize sysBadSplitInst_PortNameConflict #-} +sysBadSplitInst_PortNameConflict :: Module SplitTest +sysBadSplitInst_PortNameConflict = + module + interface + putFoo x = $display "putFoo: " (cshow x) diff --git a/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs.bsc-vcomp-out.expected b/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs.bsc-vcomp-out.expected new file mode 100644 index 000000000..e825168aa --- /dev/null +++ b/testsuite/bsc.verilog/splitports/BadSplitInst_PortNameConflict.bs.bsc-vcomp-out.expected @@ -0,0 +1,7 @@ +checking package dependencies +compiling BadSplitInst_PortNameConflict.bs +code generation for sysBadSplitInst_PortNameConflict starts +Error: "BadSplitInst_PortNameConflict.bs", line 21, column 0: (G0055) + Method `putFoo' generates a port with name `fooIn_1_x' which conflicts with + a port of the same name generated by method `putFoo' at location + "BadSplitInst_PortNameConflict.bs", line 21, column 0. diff --git a/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs b/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs new file mode 100644 index 000000000..b6bd12629 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs @@ -0,0 +1,24 @@ +package BadSplitInst_TooManyPortNames where + +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +instance SplitPorts Foo (Port (Int 8), Port (Int 8)) where + splitPorts f = (Port f.x, Port f.y) + unsplitPorts (Port x, Port y) = Foo { x=x; y=y; } + portNames _ base = Cons (base +++ "_x") $ Cons (base +++ "_y") $ Cons (base +++ "_z") Nil + +interface SplitTest = + putFoo :: Foo -> Action {-# prefix = "fooIn" #-} + +{-# synthesize sysBadSplitInst_TooManyPortNames #-} +sysBadSplitInst_TooManyPortNames :: Module SplitTest +sysBadSplitInst_TooManyPortNames = + module + interface + putFoo x = $display "putFoo: " (cshow x) diff --git a/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs.bsc-vcomp-out.expected b/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs.bsc-vcomp-out.expected new file mode 100644 index 000000000..173d964cb --- /dev/null +++ b/testsuite/bsc.verilog/splitports/BadSplitInst_TooManyPortNames.bs.bsc-vcomp-out.expected @@ -0,0 +1,8 @@ +checking package dependencies +compiling BadSplitInst_TooManyPortNames.bs +code generation for sysBadSplitInst_TooManyPortNames starts +Error: "Prelude.bs", line 4589, column 61: (S0015) + Bluespec evaluation-time error: SplitPorts: fooIn_1 has 2 ports, but 3 port + names were given + During elaboration of `sysBadSplitInst_TooManyPortNames' at + "BadSplitInst_TooManyPortNames.bs", line 20, column 0. diff --git a/testsuite/bsc.verilog/splitports/PortNameConflict.bs b/testsuite/bsc.verilog/splitports/PortNameConflict.bs new file mode 100644 index 000000000..145bb557c --- /dev/null +++ b/testsuite/bsc.verilog/splitports/PortNameConflict.bs @@ -0,0 +1,34 @@ +package PortNameConflict where + +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +instance (ShallowSplitPorts Foo p) => SplitPorts Foo p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +struct Bar = + f :: Foo + f_x :: Int 16 + deriving (Bits) + +instance (ShallowSplitPorts Bar p) => SplitPorts Bar p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +interface SplitTest = + putBar :: Bar -> Action {-# prefix = "barIn" #-} + +{-# synthesize sysPortNameConflict #-} +sysPortNameConflict :: Module SplitTest +sysPortNameConflict = + module + interface + putBar x = $display "putBar: " (cshow x) diff --git a/testsuite/bsc.verilog/splitports/PortNameConflict.bs.bsc-vcomp-out.expected b/testsuite/bsc.verilog/splitports/PortNameConflict.bs.bsc-vcomp-out.expected new file mode 100644 index 000000000..be3183ec8 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/PortNameConflict.bs.bsc-vcomp-out.expected @@ -0,0 +1,7 @@ +checking package dependencies +compiling PortNameConflict.bs +code generation for sysPortNameConflict starts +Error: "PortNameConflict.bs", line 30, column 0: (G0055) + Method `putBar' generates a port with name `barIn_1_f_x' which conflicts + with a port of the same name generated by method `putBar' at location + "PortNameConflict.bs", line 30, column 0. diff --git a/testsuite/bsc.verilog/splitports/SomeArgNames.bs b/testsuite/bsc.verilog/splitports/SomeArgNames.bs new file mode 100644 index 000000000..fd2b871fe --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SomeArgNames.bs @@ -0,0 +1,46 @@ +package SomeArgNames where + +import SplitPorts +import CShow + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +instance (ShallowSplitPorts Foo p) => SplitPorts Foo p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +struct Bar = + f :: Foo + b :: Bool + deriving (Bits) + +instance (ShallowSplitPorts Bar p) => SplitPorts Bar p where + splitPorts = shallowSplitPorts + unsplitPorts = shallowUnsplitPorts + portNames = shallowSplitPortNames + +interface SplitTest = + putFooBar :: Foo -> Bar -> Action {-# arg_names = ["fooIn"] #-} + +{-# synthesize mkSomeArgNamesSplitTest #-} +mkSomeArgNamesSplitTest :: Module SplitTest +mkSomeArgNamesSplitTest = + module + interface + putFooBar x y = $display "putFooBar: " (cshow x) " " (cshow y) + +{-# synthesize sysSomeArgNames #-} +sysSomeArgNames :: Module Empty +sysSomeArgNames = + module + s <- mkSomeArgNamesSplitTest + i :: Reg (UInt 8) <- mkReg 0 + rules + when True ==> i := i + 1 + when i == 0 ==> s.putFooBar (Foo { x = 5; y = 6; }) (Bar { f = Foo { x = 7; y = 8; }; b = True; }) + when i == 1 ==> $finish + diff --git a/testsuite/bsc.verilog/splitports/splitports.exp b/testsuite/bsc.verilog/splitports/splitports.exp index 8b49efecd..430ff5daf 100644 --- a/testsuite/bsc.verilog/splitports/splitports.exp +++ b/testsuite/bsc.verilog/splitports/splitports.exp @@ -37,4 +37,25 @@ if { $vtest == 1 } { find_regexp mkInstanceSplitTest.v {input \[799 : 0\] putFoos_1;} find_regexp mkInstanceSplitTest.v {input \[16 : 0\] putBaz_1_a;} find_regexp mkInstanceSplitTest.v {input \[491 : 0\] putBaz_1_c;} -} \ No newline at end of file +} + +test_c_veri SomeArgNames +if { $vtest == 1 } { + find_regexp mkSomeArgNamesSplitTest.v {input \[7 : 0\] putFooBar_fooIn_x;} + find_regexp mkSomeArgNamesSplitTest.v {input \[7 : 0\] putFooBar_fooIn_y;} + find_regexp mkSomeArgNamesSplitTest.v {input \[7 : 0\] putFooBar_2_f_x;} + find_regexp mkSomeArgNamesSplitTest.v {input \[7 : 0\] putFooBar_2_f_y;} + find_regexp mkSomeArgNamesSplitTest.v {input putFooBar_2_b;} +} + +compile_verilog_fail_error PortNameConflict.bs G0055 +compare_file PortNameConflict.bs.bsc-vcomp-out + +compile_verilog_fail_error ArgNamesPragma_PortNameConflict.bs G0055 +compare_file ArgNamesPragma_PortNameConflict.bs.bsc-vcomp-out + +compile_verilog_fail_error BadSplitInst_PortNameConflict.bs G0055 +compare_file BadSplitInst_PortNameConflict.bs.bsc-vcomp-out + +compile_verilog_fail_error BadSplitInst_TooManyPortNames.bs S0015 +compare_file BadSplitInst_TooManyPortNames.bs.bsc-vcomp-out \ No newline at end of file diff --git a/testsuite/bsc.verilog/splitports/sysSomeArgNames.out.expected b/testsuite/bsc.verilog/splitports/sysSomeArgNames.out.expected new file mode 100644 index 000000000..09b08a778 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSomeArgNames.out.expected @@ -0,0 +1 @@ +putFooBar: Foo {x= 5; y= 6} Bar {f=Foo {x= 7; y= 8}; b=True}