From 4075656b2c9d7148916395f256173e6a0ce05f35 Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 10 Jul 2026 18:33:56 -0700 Subject: [PATCH 01/18] Port-splitting part 3: Clean-ups and unify input, output, and noinline This is a squash merge of GitHub PR 959, with a fix from PR 928. Refactor handling of input port splitting to avoid flattening all input ports into curried method arguments, and instead preserve tuples of port values for inputs all the way through ASyntax as ATuples. In the printing of ASyntax, method input types are now a List of types rather than a single type. Handle the case when a method argument has no ports. Add missing ATuple plumbing all the way through Verilog backend. APaths cleanup and fixes. Drop PrimUnit args in AConv instead of trying to handle zero-width wires in ASyntax. Unified _PORT_ port naming: drop ARG/RES, suffix split ports Method ports are now named consistently: an argument is _ and a result is just . When an input or output is split across several hardware ports, each port gets an extra _PORT_ suffix (e.g. enq_1_PORT_2, first_PORT_1). This replaces the _ARG__

and _RES_ scheme. MethodArg now carries a Maybe port index and MethodResult a Maybe result index (Nothing = un-split, no suffix); a shared splitPortNums helper and a new fs_port string drive the naming, and the dead fs_arg/fs_res are removed. Support SplitPorts for noinline function arguments and results. Mechanism: a new `primNoInline` evaluator primitive records the (possibly split) input/output port names -- computed by the SplitPorts class during the wrapped module's elaboration, the same way `primMethod` records method ports -- onto the foreign-function value by rewriting ICForeign.foports during IExpand. Unlike primMethod it leaves the value transparent, so a noinline result can be deconstructed in expressions. No driver (bsc.hs) changes. Tests: testsuite/bsc.verilog/splitports/Noinline*.bs Fix port mapping for imported methods with multiplicity > 1 This is taken from PR 928. createMapForOneMeth pairs each method-internal port name with the actual Verilog port name. The method side numbers ports with the multiplicity copy as the outer index and the arguments inner (matching the order AVerilogUtil's "inps" emits), but the Verilog side expanded the whole concatenated list with the ports outer and the copy inner. For a method with more than one argument and multiplicity > 1 that transposed the two lists, producing mismatched connections (e.g. .A_2 wired to the A_3 net). Expand each section (inputs, enable, outputs) with the multiplicity copy as the outer loop and the ports inner, matching both the method side and AVerilogUtil. The mult <= 1 path is unchanged. Adds bsc.verilog/portprops/IncorrectPortMapping.bsv, checking that each submodule port connects to its matching internal wire. --- src/Libraries/Base1/Prelude.bs | 49 +++- src/comp/ACheck.hs | 12 +- src/comp/ACleanup.hs | 29 ++- src/comp/AConv.hs | 51 +++- src/comp/ADropDefs.hs | 2 + src/comp/AExpand.hs | 5 +- src/comp/AExpr2Util.hs | 6 +- src/comp/ANoInline.hs | 6 + src/comp/APaths.hs | 239 +++++++++++------- src/comp/ASchedule.hs | 16 +- src/comp/AState.hs | 66 +++-- src/comp/ASyntax.hs | 159 +++++++----- src/comp/ASyntaxUtil.hs | 24 +- src/comp/AVerilogUtil.hs | 179 ++++++++++--- src/comp/BackendNamingConventions.hs | 53 ++-- src/comp/CSyntax.hs | 2 +- src/comp/CVPrint.hs | 2 +- src/comp/GenABin.hs | 2 +- src/comp/GenFuncWrap.hs | 52 ++-- src/comp/GenWrap.hs | 4 +- src/comp/IConv.hs | 18 +- src/comp/IExpand.hs | 103 ++++++-- src/comp/IExpandUtils.hs | 2 +- src/comp/ISyntax.hs | 24 +- src/comp/ISyntaxUtil.hs | 19 ++ src/comp/LambdaCalc.hs | 18 +- src/comp/LambdaCalcUtil.hs | 2 + src/comp/Parser/BSV/CVParser.lhs | 11 +- src/comp/Parser/BSV/CVParserImperative.lhs | 2 +- src/comp/Parser/Classic/CParser.hs | 3 +- src/comp/PreIds.hs | 3 + src/comp/PreStrings.hs | 4 +- src/comp/Prim.hs | 3 + src/comp/SAL.hs | 17 +- src/comp/SignalNaming.hs | 4 +- src/comp/SimCCBlock.hs | 17 +- src/comp/SimExpand.hs | 11 +- src/comp/SimMakeCBlocks.hs | 2 +- src/comp/SimPackage.hs | 2 +- src/comp/TCheck.hs | 50 ++-- src/comp/VIOProps.hs | 14 +- src/comp/VModInfo.hs | 13 +- src/comp/bluetcl.hs | 71 +++--- .../bsc.evaluator/mkTest.atsexpand.expected | 8 +- .../mkTest.atsexpand.nolift.expandif.expected | 8 +- ...ormConstantAcrossEquals.atsexpand.expected | 8 +- .../bsc.evaluator/sysShiftMult.ats.expected | 4 +- ...alNum_ENotation.bsv.bsc-vcomp-out.expected | 2 +- .../Method.bsv.bsc-vcomp-out.expected | 2 +- .../MethodRead.bsv.bsc-vcomp-out.expected | 2 +- testsuite/bsc.scheduler/paths/paths.exp | 43 ++-- .../sat/SplitTupleMethodTest.bsv | 80 ++++++ ...hodTest_sat-stp.bsv.bsc-sched-out.expected | 107 ++++++++ ...dTest_sat-yices.bsv.bsc-sched-out.expected | 107 ++++++++ testsuite/bsc.scheduler/sat/sat.exp | 2 +- .../sysStateNameTest.atsexpand.expected | 2 +- .../sysStateNameTest2.atsexpand.expected | 2 +- .../statename/sysUseMod2.atsexpand.expected | 2 +- .../sysUseMod2Arrow.atsexpand.expected | 2 +- .../DummyInRuleQual.bs.bsc-vcomp-out.expected | 2 +- .../portprops/IncorrectPortMapping.bsv | 34 +++ testsuite/bsc.verilog/portprops/portprops.exp | 13 + .../splitports/NoinlineDeepSplit.bs | 43 ++++ .../bsc.verilog/splitports/NoinlineSplit.bs | 33 +++ .../splitports/NoinlineSplitMulti.bs | 33 +++ .../splitports/NoinlineSplitTuple.bs | 21 ++ .../splitports/NoinlineSplitTuple3.bs | 24 ++ .../bsc.verilog/splitports/SplitArgSlice.bs | 42 +++ .../bsc.verilog/splitports/SplitInputRegs.bs | 44 ++++ .../splitports/SplitTupleSensitivity.bs | 38 +++ .../bsc.verilog/splitports/splitports.exp | 131 ++++++++++ .../sysNoinlineDeepSplit.out.expected | 1 + .../splitports/sysNoinlineSplit.out.expected | 1 + .../sysNoinlineSplitMulti.out.expected | 1 + .../sysNoinlineSplitTuple.out.expected | 1 + .../sysNoinlineSplitTuple3.out.expected | 1 + .../splitports/sysSplitArgSlice.out.expected | 4 + .../splitports/sysSplitInputRegs.out.expected | 1 + .../sysSplitTupleSensitivity.out.expected | 7 + 79 files changed, 1729 insertions(+), 498 deletions(-) create mode 100644 testsuite/bsc.scheduler/sat/SplitTupleMethodTest.bsv create mode 100644 testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-stp.bsv.bsc-sched-out.expected create mode 100644 testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-yices.bsv.bsc-sched-out.expected create mode 100644 testsuite/bsc.verilog/portprops/IncorrectPortMapping.bsv create mode 100644 testsuite/bsc.verilog/splitports/NoinlineDeepSplit.bs create mode 100644 testsuite/bsc.verilog/splitports/NoinlineSplit.bs create mode 100644 testsuite/bsc.verilog/splitports/NoinlineSplitMulti.bs create mode 100644 testsuite/bsc.verilog/splitports/NoinlineSplitTuple.bs create mode 100644 testsuite/bsc.verilog/splitports/NoinlineSplitTuple3.bs create mode 100644 testsuite/bsc.verilog/splitports/SplitArgSlice.bs create mode 100644 testsuite/bsc.verilog/splitports/SplitInputRegs.bs create mode 100644 testsuite/bsc.verilog/splitports/SplitTupleSensitivity.bs create mode 100644 testsuite/bsc.verilog/splitports/sysNoinlineDeepSplit.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysNoinlineSplit.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysNoinlineSplitMulti.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple3.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysSplitArgSlice.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysSplitInputRegs.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysSplitTupleSensitivity.out.expected diff --git a/src/Libraries/Base1/Prelude.bs b/src/Libraries/Base1/Prelude.bs index 55fa7d573..bcdcf3987 100644 --- a/src/Libraries/Base1/Prelude.bs +++ b/src/Libraries/Base1/Prelude.bs @@ -259,7 +259,7 @@ package Prelude( NumConArg(..), StarConArg(..), OtherConArg(..), MetaConsNamed(..), MetaConsAnon(..), MetaField(..), - WrapField(..), WrapMethod(..), WrapPorts(..), NonEmptyBits(..), + WrapField(..), WrapMethod(..), fromWrapNoInline, WrapPorts(..), NonEmptyBits(..), Port(..), unPort, SplitPorts(..), PrimSeqTupleBits(..) ) where @@ -4622,8 +4622,17 @@ data (MetaField :: $ -> # -> *) name idx = MetaField deriving (FShow) --- Tag a method with metadata: the input and output port names. -primitive primMethod :: List String -> List String -> a -> a +-- Tag a method with metadata: the input port names for each method argument, +-- and the output port names. +primitive primMethod :: List (List String) -> List String -> a -> a + +-- Like primMethod, but for a noinline function: records the (possibly split) +-- input and output port names directly on the foreign-function value, so that +-- a call to it connects to the same port names that the generated module +-- exposes. Unlike primMethod, it does not wrap the result value (which would +-- not be transparent to expression evaluation); it annotates the foreign +-- function in place. +primitive primNoInline :: List (List String) -> List String -> a -> a -- Convert bewtween a field in an interface that is being synthesized, -- and a field in the corresponding field in the generated wrapper interface. @@ -4676,6 +4685,20 @@ instance (Bits a n) => WrapField name (Inout a) (Inout_ n) where saveFieldPortTypes _ _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: (Inout a)) +-- Like fromWrapMethod, but for a noinline function: also records the (possibly +-- split) input and output port names of the function via primNoInline, so that +-- a call to the noinline function connects to the same port names that the +-- generated module exposes. noinline functions do not support naming pragmas, +-- so the function name is used both as the prefix for naming both the input +-- and output ports; only the arg names are supplied separately. +fromWrapNoInline :: (WrapMethod m w) => String -> List String -> w -> m +fromWrapNoInline name argNames x = + let argBaseNames = methodArgBaseNames (_ :: m) name argNames 1 + in fromWrapMethod (primNoInline + (inputPortNames (_ :: m) argBaseNames) + (outputPortNames (_ :: m) name) + x) + class WrapMethod m w | m -> w where -- Convert a synthesized interface method to its wrapper interface method. toWrapMethod :: m -> w @@ -4686,19 +4709,21 @@ 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 - -- Compute the list of input port names for a method, from the argument base names. - inputPortNames :: m -> List String -> List String + -- Compute the list of input port names for each method argument, given the per-argument base names. + inputPortNames :: m -> List String -> List (List String) - -- Compute the list of input port names for a method, from the result base name. + -- Compute the list of output port names for a method, from the result base name. outputPortNames :: m -> String -> List String -- 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 (WrapPorts (PortsOf a) 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 +instance (WrapPorts (PortsOf a) pb, PrimSeqTupleBits pb, WrapMethod b v) => + WrapMethod (a -> b) (pb -> v) where + -- deep-seq the packed argument so its per-port fields are evaluated before + -- they reach walkNF (mirroring the deep-seq already done on method results) + toWrapMethod f = toWrapMethod ∘ f ∘ unsplitPorts ∘ unpackPorts ∘ primDeepSeqTupleBits + fromWrapMethod g = fromWrapMethod ∘ g ∘ primDeepSeqTupleBits ∘ packPorts ∘ splitPorts methodArgBaseNames _ prefix (Cons h t) i = Cons -- arg_names can start with a digit @@ -4711,8 +4736,8 @@ instance (WrapPorts (PortsOf a) pb, WrapMethod b v, Curry (pb -> v) w) => (methodArgBaseNames (_ :: b) prefix Nil $ i + 1) inputPortNames _ (Cons h t) = - filterZeroWidthPorts (_ :: PortsOf a) (checkPortNames (_ :: a) h) - `listPrimAppend` inputPortNames (_ :: b) t + Cons (filterZeroWidthPorts (_ :: PortsOf a) (checkPortNames (_ :: a) h)) + (inputPortNames (_ :: b) t) inputPortNames _ Nil = error "inputPortNames: empty arg names list" outputPortNames _ = outputPortNames (_ :: b) diff --git a/src/comp/ACheck.hs b/src/comp/ACheck.hs index cc044f850..6c41db77f 100644 --- a/src/comp/ACheck.hs +++ b/src/comp/ACheck.hs @@ -111,10 +111,18 @@ chkAIface aa@(AIInout { aif_inout = r }) = chkCond :: AType -> Bool chkCond = isBit1 +-- A method argument must either be a Bit-typed expression (a single +-- hardware input port) or an ATuple of Bit-typed elements (one per +-- hardware input port, for SplitPorts arguments). +chkMethArg :: AExpr -> Bool +chkMethArg e = case chkAExpr e of + ATTuple ts -> all isBit ts + t -> isBit t + chkAAction :: AAction -> Bool chkAAction aa@(ACall i m (c:es)) = tracePP "chkAAction ACall" aa $ - all (isBit . chkAExpr) es && chkCond (chkAExpr c) + all chkMethArg es && chkCond (chkAExpr c) chkAAction afc@(AFCall { aact_objid = i, aact_args = (c:es) }) = tracePP "chkAAction AFCall" afc $ chkCond (chkAExpr c) && all (isForeignArg . chkAExpr) es @@ -263,7 +271,7 @@ chkAExpr e@(APrim _ t op es) = else internalError ("chkAExpr: other " ++ ppReadable (e, t, map chkAExpr es)) chkAExpr e@(AMethCall t _ _ es) = - if all (isBit . chkAExpr) es + if all chkMethArg es then t else internalError ("chkAExpr: methcall " ++ ppReadable e) chkAExpr e@(AFunCall { ae_type = t, ae_args = es }) = diff --git a/src/comp/ACleanup.hs b/src/comp/ACleanup.hs index 0c660f701..68ea9e0c3 100644 --- a/src/comp/ACleanup.hs +++ b/src/comp/ACleanup.hs @@ -6,7 +6,7 @@ import DisjointTest(DisjointTestState, initDisjointTestState, addADefToDisjointTestState, checkDisjointExprWithCtx) import Data.Maybe import Flags(Flags) -import Control.Monad(when) +import Control.Monad(when, zipWithM) import Control.Monad.State(StateT, evalStateT, liftIO, get, put) import FStringCompat(mkFString) import Position(noPosition) @@ -142,17 +142,22 @@ cleanupActions flags pred as = newid <- newName addDef (ADef newid aTBool (APrim newid aTBool PrimBOr [cond, cond']) []) - newargs <- - (mapM (\ (arg, arg') -> - do - argid <- newName - let argtyp = (aType arg) - addDef (ADef argid argtyp - (APrim argid argtyp PrimIf [cond, arg, arg']) []) - return (ASDef argtyp argid)) - (zip args args')) - let newcall = (ACall id methodid - ((ASDef aTBool newid):newargs)) + -- For SplitPorts args (ATuple), merge per element so + -- the resulting AExpr keeps the source-arg shape. + let mergeOne arg arg' = do + argid <- newName + let argtyp = (aType arg) + addDef (ADef argid argtyp + (APrim argid argtyp PrimIf + [cond, arg, arg']) []) + return (ASDef argtyp argid) + mergeArg (ATuple ty es) (ATuple _ es') = do + es'' <- zipWithM mergeOne es es' + return (ATuple ty es'') + mergeArg arg arg' = mergeOne arg arg' + newargs <- zipWithM mergeArg args args' + let newcall = ACall id methodid + (ASDef aTBool newid : newargs) -- restR is guaranteed merged amongst itself (see below) -- so no more work need be done... diff --git a/src/comp/AConv.hs b/src/comp/AConv.hs index 9259beccd..92660edc9 100644 --- a/src/comp/AConv.hs +++ b/src/comp/AConv.hs @@ -186,11 +186,11 @@ aDo imod@(IModule mi fmod be wi ps iks its clks rsts itvs pts idefs rs ifc ffcal flags <- getFlags -- AVInst keeps the types of method ports - let tsConv :: Id -> [IType] -> ([AType], Maybe AType, [AType]) + let tsConv :: Id -> [IType] -> ([[AType]], Maybe AType, [AType]) tsConv i ts = let inputs = initOrErr "tsConv" ts res = lastOrErr "tsConv" ts - in_types = map (aTypeConv i) inputs + in_types = map (aTupleTypesConv i) inputs (en_type, val_type) | isitActionValue_ res = (Just (ATBit 1), aTupleTypesConv i (getAV_Type res)) @@ -336,7 +336,13 @@ aAbstractInput (IAI_Inout r n) = (AAI_Inout r n) aIface :: Flags -> IEFace a -> M AIFace aIface flags iface@(IEFace i its maybe_e maybe_rs wp fi) = do --trace ("enter " ++ ppReadable i) $ return () - let its' = [ (arg_i, aTypeConv arg_i arg_t) | (arg_i, arg_t) <- its] + -- `its` is grouped by source-language argument (one inner list per + -- argument); aif_inputs keeps that grouping, with one inner list of + -- ports per argument (a singleton for an unsplit argument, several for + -- a struct/tuple argument split into multiple ports by SplitPorts). + let its' = [ [ (arg_i, aTypeConv arg_i arg_t) + | (arg_i, arg_t) <- group ] + | group <- its ] g = if isRdyId i then aSBool True else ASDef aTBool (mkRdyId i) case (maybe_e, maybe_rs) of (Nothing, Nothing) -> internalError ("AConv.aIface nothing in it " @@ -441,6 +447,14 @@ aClock c = do aclock_gate = gate_aexpr }) _ -> internalError ("AConv.ASClock: " ++ (show c)) +-- A wrapped method has () for arguments that have no non-empty ports, +-- we drop them when converting to ASyntax. +dropPrimUnitArgs :: [IExpr a] -> [IExpr a] +dropPrimUnitArgs = filter (not . isPrimUnitArg) + where + isPrimUnitArg (ICon i _) = i == idPrimUnit + isPrimUnitArg _ = False + aSExpr :: IExpr a -> M AExpr aSExpr e = do e' <- aExpr e @@ -605,6 +619,7 @@ aTupleExpr (IAps (ICon i _) [t1, t2] [e1, e2]) | i == idPrimPair = do ae1 <- aSExpr e1 ae2 <- aTupleExpr e2 return (ae1:ae2) +aTupleExpr (ICon i _) | i == idPrimUnit = return [] aTupleExpr e = fmap (:[]) (aSExpr e) -- the PrimFst/PrimSnd selectors that project an element out of a @@ -648,7 +663,7 @@ aSelExpr [(m, t)] [(IAps (ICon i (ICForeign {fName = name, aSelExpr sels (ICon i (ICStateVar { }) : es) | (pfx@((_, atype) : _), [(m, atypeTup)]) <- span (isTupleSelector . fst) sels = do i' <- transId i - es' <- mapM aSExpr es + es' <- mapM aSExpr (dropPrimUnitArgs es) let idx = toInteger $ length (filter ((== idPrimSnd) . fst) pfx) return $ ATupleSel atype (AMethCall atypeTup i' m es') (idx + 1) @@ -680,8 +695,9 @@ aSelExpr sels base@(ICon i (ICStateVar { }) : es) -- value method aSelExpr [(m, atype)] (ICon i (ICStateVar { }) : es) = do i' <- transId i - es' <- mapM aSExpr es - return $ AMethCall atype i' m es' + -- one AExpr per source argument; SplitPorts args are ATuple AExprs + args <- mapM aSExpr (dropPrimUnitArgs es) + return $ AMethCall atype i' m args aSelExpr [(m, _)] [ICon i (ICClock { iClock = c })] | m == idClockGate = do ac <- aClock c @@ -692,6 +708,22 @@ aSelExpr [(m, _)] [ICon i (ICClock { iClock = c })] | m == idClockOsc = do ac <- aClock c return (aclock_osc ac) +-- tuple (fst/snd) selection from the result of a noinline (foreign) function. +-- The foreign call produces the combined result value; ATupleSel picks out +-- the element. The element index is the number of "snd" selectors in the +-- chain (a flat tuple (a,b,c) is the right-nested pairs (a,(b,c)), so the +-- k-th element is reached by k snds followed by an fst). +aSelExpr sels@(_:_) [fcall] + | all ((\ s -> s == idPrimFst || s == idPrimSnd) . fst) sels + , isForeignFunCall fcall = do + fcall' <- aExpr fcall + let atype = snd (headOrErr "AConv.aSelExpr: foreign sel" sels) + idx = genericLength (filter ((== idPrimSnd) . fst) sels) + return $ ATupleSel atype fcall' (idx + 1) + where isForeignFunCall (ICon _ (ICForeign { foports = Just _ })) = True + isForeignFunCall (IAps (ICon _ (ICForeign { foports = Just _ })) _ _) = True + isForeignFunCall _ = False + aSelExpr sels base = internalError ("AConv.aSelExpr:" ++ ppReadable sels ++ "\n" ++ ppReadable base) @@ -755,6 +787,7 @@ aTypeConvE a t = abs t [] internalError ("aTypeConvE|" ++ show t) aTupleTypesConv :: Id -> IType -> [AType] +aTupleTypesConv _ t | t == itPrimUnit = [] aTupleTypesConv a (ITAp (ITAp (ITCon p _ _) t1) t2) | p == idPrimPair = aTypeConv a t1 : aTupleTypesConv a t2 aTupleTypesConv a t = [aTypeConv a t] @@ -921,7 +954,11 @@ aAction1 r cond a@(IAps (ICon avAction_ (ICSel { })) _ es) | avAction_ == idAVAc aAction1 _ cond (IAps (ICon m (ICSel { })) _ (ICon i (ICStateVar { }) : es)) = do cond' <- aSExpr cond - es' <- mapM aSExpr es + -- One AExpr per source argument. aSExpr produces an ATuple AExpr + -- for a SplitPorts argument whose IExpr is a PrimPair; consumers + -- that walk individual hardware ports match on ATuple to split + -- those tuples back into per-port AExprs. + es' <- mapM aSExpr (dropPrimUnitArgs es) i' <- transId i return [ACall i' m (cond' : es')] diff --git a/src/comp/ADropDefs.hs b/src/comp/ADropDefs.hs index fe6554997..92cf72310 100644 --- a/src/comp/ADropDefs.hs +++ b/src/comp/ADropDefs.hs @@ -16,6 +16,8 @@ dVars = findAExprs dVarsE dVarsE (AMethCall { ae_args = es}) = dVars es dVarsE (ANoInlineFunCall { ae_args = es }) = dVars es dVarsE (AFunCall { ae_args = es }) = dVars es + dVarsE (ATuple _ es) = dVars es + dVarsE (ATupleSel _ e _) = dVars e dVarsE _ = [] aDropDefs :: ASPackage -> ASPackage diff --git a/src/comp/AExpand.hs b/src/comp/AExpand.hs index 8b00f678d..7065f5dce 100644 --- a/src/comp/AExpand.hs +++ b/src/comp/AExpand.hs @@ -367,7 +367,10 @@ xaSRemoveUnused keepFires pkg = let en = case (vf_enable m) of Nothing -> [] Just _ -> [MethodEnable] - args = map MethodArg [1..genericLength (vf_inputs m)] + -- enumerate MethodArg per (argN, portM) coordinate + args = [ MethodArg argN portM + | (argN, ports) <- zip [1..] (vf_inputs m) + , (portM, _) <- zip (splitPortNums ports) ports ] in [ mkMethId v i ino part | part <- en ++ args, ino <- if mult > 1 then map Just [0 .. mult-1] diff --git a/src/comp/AExpr2Util.hs b/src/comp/AExpr2Util.hs index 3f8111775..6c65208f9 100644 --- a/src/comp/AExpr2Util.hs +++ b/src/comp/AExpr2Util.hs @@ -61,10 +61,12 @@ getSingleMethodOutputPort stateMap modId methId = ppReadable (modId, methId, ports)) -- The output port at the given tuple-selector index, for a method whose result --- is split across multiple output ports. +-- is split across multiple output ports. ATupleSel indices are 1-based (AConv +-- builds them as idx + 1), while getMethodOutputPorts is a 0-based list, so +-- shift by one to index it. getMethodOutputPortAt :: (M.Map AId VModInfo) -> AId -> AId -> Integer -> AId getMethodOutputPortAt stateMap modId methId selIdx = - getMethodOutputPorts stateMap modId methId `genericIndex` selIdx + getMethodOutputPorts stateMap modId methId `genericIndex` (selIdx - 1) -- ------------------------- diff --git a/src/comp/ANoInline.hs b/src/comp/ANoInline.hs index 8b5449fed..43bf6b1ce 100644 --- a/src/comp/ANoInline.hs +++ b/src/comp/ANoInline.hs @@ -163,6 +163,12 @@ liftAExpr _ (AMethCall ty aid mid es) = do liftAExpr _ (AFunCall ty aid fun isC es) = do es' <- mapM (liftAExpr False) es return $ AFunCall ty aid fun isC es' +liftAExpr _ (ATupleSel ty e idx) = do + e' <- liftAExpr False e + return $ ATupleSel ty e' idx +liftAExpr _ (ATuple ty es) = do + es' <- mapM (liftAExpr False) es + return $ ATuple ty es' liftAExpr _ expr = return expr -- =============== diff --git a/src/comp/APaths.hs b/src/comp/APaths.hs index 5b761890e..203283739 100644 --- a/src/comp/APaths.hs +++ b/src/comp/APaths.hs @@ -107,16 +107,18 @@ import ErrorMonad(ErrorMonad(..), convErrorMonadToIO) import PFPrint import Flags(Flags) import ASyntax +import ASyntaxUtil(argInputPorts) import Error(internalError, EMsg, ErrMsg(..), ErrorHandle) import VModInfo(vPath, vFields, vArgs, VPathInfo(..), VName(..), VFieldInfo(..), VArgInfo(..), VWireInfo(..), getInputClockPorts, getInputResetPorts, - isClock, isReset, isPort, isParam, id_to_vName,mkNamedEnable) + isClock, isReset, isPort, isParam, id_to_vName, + mkNamedEnable, mkNamedOutputs) import Pragma import Control.Monad(when) import Data.Maybe(isJust, isNothing, fromJust) -import Data.List(partition, genericIndex) +import Data.List(partition, genericIndex, genericLength) import Id(unQualId, getIdBaseString) import Eval import Position(getPosition) @@ -141,7 +143,11 @@ trace_apaths = "-trace-apaths" `elem` progArgs -- -type PathEnv = M.Map AId PathNode +-- Maps the Id of each local def and module input to its PathNode(s). The +-- value is a list because a def that binds a tuple is a bundle of independent +-- per-element signals, each with its own node (see PNDefTupleElem); ordinary +-- names map to a singleton. +type PathEnv = M.Map AId [PathNode] -- The information that is passed between the pre and post scheduler stages data PathGraphInfo = PathGraphInfo @@ -168,8 +174,14 @@ type PathUrgencyPairs = [(ARuleId, ARuleId, [PathNode])] data PathNode = -- ID in the ADefT PNDef AId | - -- arguments to methods of submodules (Ids: instance, method, arg #) - PNStateMethodArg AId AId Integer | + -- one element of a local def that binds a tuple value (Ids: def, 1-based + -- element index). A tuple-valued def is a bundle of independent per-element + -- signals, so each element is its own node -- exactly as PNDef is for a + -- scalar def -- rather than collapsing the elements into a single node. + PNDefTupleElem AId Integer | + -- arguments to methods of submodules + -- (Ids: instance, method, source-arg #, port-within-arg #) + PNStateMethodArg AId AId Integer Integer | -- return values of methods of submodules (Ids: instance, method, result #) PNStateMethodRes AId AId Integer | -- enable signal of action methods of submodules (Ids: instance, method) @@ -188,10 +200,10 @@ data PathNode = PNCanFire AId | -- enable signal of a method or rule PNWillFire AId | - -- arguments to methods of current module (Ids: method, argument) + -- arguments to methods of current module (Ids: method, input port) PNTopMethodArg AId AId | - -- return values of methods of current module (Ids: method, result #) - PNTopMethodRes AId Integer | + -- return values of methods of current module (Ids: method, output port) + PNTopMethodRes AId AId | -- this is an internal graph node for the method's ready signal, -- the real output port is handled by a separate read method -- (Id: method) @@ -224,8 +236,12 @@ printPathNode use_pvprint d p node = in case (node) of (PNDef def_id) -> fsep [text "Definition", quotes (pp def_id)] - (PNStateMethodArg inst_id meth_id port_id) -> - fsep [text "Argument", pp port_id, + (PNDefTupleElem def_id idx) -> + fsep [text "Definition", quotes (pp def_id), + s2par "element", pp idx] + (PNStateMethodArg inst_id meth_id arg_id port_id) -> + fsep [text "Argument", pp arg_id, + s2par "port", pp port_id, s2par "of method", quotes (pp meth_id), s2par "of submodule", quotes (pp inst_id)] (PNStateMethodRes inst_id meth_id port_id) -> @@ -255,8 +271,8 @@ printPathNode use_pvprint d p node = (PNTopMethodArg meth_id arg_id) -> fsep [text "Argument", pp arg_id, s2par "of top-level method", quotes (pp meth_id)] - (PNTopMethodRes meth_id res_num) -> - fsep [text "Output", pp res_num, + (PNTopMethodRes meth_id res_id) -> + fsep [text "Output", pp res_id, s2par "of top-level method", quotes (pp meth_id)] (PNTopMethodReady meth_id) -> fsep [s2par "Ready condition", @@ -289,7 +305,8 @@ instance PVPrint PathNode where instance NFData PathNode where rnf (PNDef aid) = rnf aid - rnf (PNStateMethodArg a1 a2 n) = rnf3 a1 a2 n + rnf (PNDefTupleElem aid n) = rnf2 aid n + rnf (PNStateMethodArg a1 a2 n1 n2) = rnf4 a1 a2 n1 n2 rnf (PNStateMethodRes a1 a2 n) = rnf3 a1 a2 n rnf (PNStateMethodEnable a1 a2) = rnf2 a1 a2 rnf (PNStateArgument aid vn n) = rnf3 aid vn n @@ -297,7 +314,7 @@ instance NFData PathNode where rnf (PNCanFire aid) = rnf aid rnf (PNWillFire aid) = rnf aid rnf (PNTopMethodArg a1 a2) = rnf2 a1 a2 - rnf (PNTopMethodRes aid n) = rnf2 aid n + rnf (PNTopMethodRes a1 a2) = rnf2 a1 a2 rnf (PNTopMethodReady aid) = rnf aid rnf (PNTopMethodEnable aid) = rnf aid rnf (PNTopArgument aid n) = rnf2 aid n @@ -311,6 +328,7 @@ instance NFData PathNode where filterPNDefs :: [PathNode] -> [PathNode] filterPNDefs pns = filter (not . isPNDef) pns where isPNDef (PNDef _) = True + isPNDef (PNDefTupleElem _ _) = True isPNDef _ = False alwaysRdyNode :: [PProp] -> PathNode -> Bool @@ -458,8 +476,14 @@ aPathsPreSched errh flags apkg = do -- ==================== -- Determine the nodes of the graph - let defs = [(i, PNDef i) | (ADef i _ _ _) <- ds] - def_nodes = map snd defs + -- A def that binds a tuple gets one node per element (PNDefTupleElem); any + -- other def gets a single PNDef node. This keeps the per-element signals of + -- a tuple distinct so that selecting one element does not pull in the others. + let defNodes (ADef i (ATTuple ts) _ _) = + [ PNDefTupleElem i k | k <- [1 .. genericLength ts] ] + defNodes (ADef i _ _ _) = [PNDef i] + defs = [(i, defNodes d) | d@(ADef i _ _ _) <- ds] + def_nodes = concatMap snd defs -- ---------- @@ -481,7 +505,8 @@ aPathsPreSched errh flags apkg = do -- XXX is the VeriPortProp info worth keeping? state_instances :: [ ( AId, [(VName, VName)], [(VName, Integer, AExpr)], - [(AId, [(VName,Integer)], Maybe VName, [(VName, Integer)], Maybe AId)] ) ] + [(AId, [(VName,Integer,Integer)], Maybe VName, + [(VName, Integer)], Maybe AId)] ) ] state_instances = [(inst_id, nns, args, meth_info) | avi <- vs, @@ -500,8 +525,12 @@ aPathsPreSched errh flags apkg = do let meth_info = [(meth_id, numbered_args, maybe_EN, numbered_res, maybe_clk) | vfieldinfo@(Method { vf_name = meth_id }) <- vFields vmi, - let args = map fst (vf_inputs vfieldinfo), - let numbered_args = zip args [1..], + -- one (vname, arg#, port#) triple per port, + -- preserving source-argument grouping from vf_inputs + let numbered_args = + [ (vname, argN, portM) + | (argN, argPorts) <- zip [1..] (vf_inputs vfieldinfo) + , (portM, (vname, _)) <- zip [1..] argPorts ], let maybe_EN = (vf_enable vfieldinfo) >>= return . fst, let res = (vf_outputs vfieldinfo) >>= return . fst, let numbered_res = zip res [1..], @@ -510,10 +539,10 @@ aPathsPreSched errh flags apkg = do ] state_input_nodes = - [ PNStateMethodArg inst_id meth_id arg_num | + [ PNStateMethodArg inst_id meth_id arg_num port_num | (inst_id, _, _, methods) <- state_instances, (meth_id, numbered_args, maybe_EN, _, _) <- methods, - arg_num <- map snd numbered_args + (_, arg_num, port_num) <- numbered_args ] state_output_nodes = [ PNStateMethodRes inst_id meth_id res_num | @@ -559,24 +588,21 @@ aPathsPreSched errh flags apkg = do -- ---------- let method_inputs = - [(arg, PNTopMethodArg m arg) | (AIDef { aif_inputs = args, - aif_name = m }) <- ifc, - (arg,_) <- args] ++ - [(arg, PNTopMethodArg m arg) | (AIAction { aif_inputs = args, - aif_name = m }) <- ifc, - (arg,_) <- args] ++ - [(arg, PNTopMethodArg m arg) | (AIActionValue { aif_inputs = args, - aif_name = m }) <- ifc, - (arg,_) <- args] - - num_outputs (ADef {adef_type = ATTuple ts}) = fromIntegral (length ts) - num_outputs _ = 1 + [(arg, PNTopMethodArg m arg) | iface@(AIDef { aif_name = m }) <- ifc, + (arg,_) <- aIfaceArgs iface] ++ + [(arg, PNTopMethodArg m arg) | iface@(AIAction { aif_name = m }) <- ifc, + (arg,_) <- aIfaceArgs iface] ++ + [(arg, PNTopMethodArg m arg) | iface@(AIActionValue { aif_name = m }) <- ifc, + (arg,_) <- aIfaceArgs iface] + + -- Per-port output names for a method (one Id per hardware output port). + methodOutputIds iface = mkNamedOutputs (aif_fieldinfo iface) method_outputs = - [(m, PNTopMethodRes m res) | (AIDef { aif_name = m, aif_value = v }) <- ifc, - res <- [1..(num_outputs v)] ] ++ - [(m, PNTopMethodRes m res) | (AIActionValue { aif_name = m, aif_value = v }) <- ifc, - res <- [1..(num_outputs v)] ] + [(m, PNTopMethodRes m o) | iface@(AIDef { aif_name = m }) <- ifc, + o <- methodOutputIds iface ] ++ + [(m, PNTopMethodRes m o) | iface@(AIActionValue { aif_name = m }) <- ifc, + o <- methodOutputIds iface ] method_enables = -- Name creation is safe, since it is based on VFieldInfo @@ -670,7 +696,8 @@ aPathsPreSched errh flags apkg = do -- add ifc_env elements one-by-one, -- bailing with an error if we ever need to combine - let env = foldr (uncurry (M.insertWith overlap_error)) def_map ifc_env + let env = foldr (uncurry (M.insertWith overlap_error)) def_map + [ (i, [n]) | (i, n) <- ifc_env ] when trace_apaths $ traceM ("env = " ++ ppReadable (M.toList env)) @@ -683,32 +710,48 @@ aPathsPreSched errh flags apkg = do -- -------------------- -- Defs (ds) - let mkDefEdges (ADef i _ e _) = mkEdges (PNDef i) e env + -- For a tuple-binding def, connect each element's contributors to that + -- element's node; for any other def, connect to its single PNDef node. + let mkDefEdges (ADef i (ATTuple ts) e _) = + concat [ mkElemEdges i e k et | (k, et) <- zip [1..] ts ] + mkDefEdges (ADef i _ e _) = mkEdges (PNDef i) e env + -- APaths assumes tuples are flat (SplitPorts flattens even deep splits to + -- a tuple of leaves), so a tuple element should never itself be a tuple. + mkElemEdges i _ _ (ATTuple _) = + internalError ("APaths.mkDefEdges: nested tuple in def " ++ + ppReadable i ++ " -- tuples are expected to be " ++ + "flattened before path analysis") + mkElemEdges i e k et = mkEdges (PNDefTupleElem i k) (tupleElemExpr e et k) env + -- the k-th element (1-based) of a tuple-valued expression: index a + -- literal tuple directly, otherwise select it (handled by findEdges) + tupleElemExpr (ATuple _ es) _ k = es `genericIndex` (k - 1) + tupleElemExpr e et k = ATupleSel et e k def_edges = concatMap mkDefEdges ds -- -------------------- -- methods (ifc) let mkMethodEdges :: AIFace -> [(PathNode,PathNode)] - mkMethodEdges (AIDef mid inputs wp rdy def@(ADef _ t e _) _ _) = + mkMethodEdges iface@(AIDef mid _ wp rdy def@(ADef _ t e _) _ _) = -- connect the rdy expression (likely just an ASDef reference) -- to the internal graph node for the method ready (mkEdges (PNTopMethodReady mid) rdy env) ++ -- make faux connections from the rdy to the arguments, so that -- dependencies in the other direction are caught as loops - [(PNTopMethodReady mid, PNTopMethodArg mid arg) | (arg,_) <- inputs] ++ + [(PNTopMethodReady mid, PNTopMethodArg mid arg) | (arg,_) <- aIfaceArgs iface] ++ if length result_types /= length results then internalError ("APaths.aPathsPreSched: unexpected method results: " ++ ppReadable def) -- connect the definition to the method result -- (this method has no enable, so it cannot contribute to any -- methcall argument muxes, so just use "mkEdges") - else [edge | (res, e') <- zip [1..] results, edge <- mkEdges (PNTopMethodRes mid res) e' env] + else [edge | (resId, e') <- zip (methodOutputIds iface) results, + edge <- mkEdges (PNTopMethodRes mid resId) e' env] where result_types | ATTuple ts <- t = ts | otherwise = [t] results | ATuple { ae_elems = elems } <- e = elems | otherwise = [e] - mkMethodEdges (AIAction inputs wp rdy m rs fi) = + mkMethodEdges iface@(AIAction _ wp rdy m rs fi) = let rdy_node = PNTopMethodReady m en_node = PNTopMethodEnable m mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = @@ -736,11 +779,11 @@ aPathsPreSched errh flags apkg = do -- as loops [(rdy_node, en_node)] ++ [(rdy_node, PNTopMethodArg m arg) - | (arg,_) <- inputs] ++ + | (arg,_) <- aIfaceArgs iface] ++ -- connect the rules concatMap mkMRuleEdges rs - mkMethodEdges (AIActionValue inputs wp rdy m rs def@(ADef _ t e _) fi) = + mkMethodEdges iface@(AIActionValue _ wp rdy m rs def@(ADef _ t e _) fi) = let rdy_node = PNTopMethodReady m en_node = PNTopMethodEnable m mkMRuleEdges (ARule ri _ _ _ rpred actions _ _) = @@ -772,15 +815,15 @@ aPathsPreSched errh flags apkg = do -- as loops [(rdy_node, en_node)] ++ [(rdy_node, PNTopMethodArg m arg) - | (arg,_) <- inputs] ++ + | (arg,_) <- aIfaceArgs iface] ++ (if length result_types /= length results then internalError ("APaths.aPathsPreSched: unexpected method results: " ++ ppReadable def) -- connect the definitions to the method results -- (this method's Enable could contribute to methcall argument -- muxes, so use "mkEdgesWithMux") - else [edge | (res, e') <- zip [1..] results, - edge <- (mkEdgesWithMux en_node (PNTopMethodRes m res) e' env)]) ++ + else [edge | (resId, e') <- zip (methodOutputIds iface) results, + edge <- (mkEdgesWithMux en_node (PNTopMethodRes m resId) e' env)]) ++ -- connect the rules concatMap mkMRuleEdges rs @@ -823,9 +866,9 @@ aPathsPreSched errh flags apkg = do (meth_id, _, Just enable, _, clk) <- methods, enable == vname ] ++ - [ (clk, PNStateMethodArg inst_id meth_id arg_num) | + [ (clk, PNStateMethodArg inst_id meth_id arg_num port_num) | (meth_id, args, _, _, clk) <- methods, - (arg, arg_num) <- args, + (arg, arg_num, port_num) <- args, arg == vname ] @@ -854,10 +897,10 @@ aPathsPreSched errh flags apkg = do -- Connect the control mux for a method to the arguments of that method let state_mux_edges = [ (PNStateMethodArgMux inst_id meth_id, - PNStateMethodArg inst_id meth_id arg_num) | + PNStateMethodArg inst_id meth_id arg_num port_num) | (inst_id, _, _, methods) <- state_instances, (meth_id, args, _, _, _) <- methods, - (_, arg_num) <- args ] + (_, arg_num, port_num) <- args ] -- Combine all the submodule edges let state_edges = @@ -927,13 +970,14 @@ aPathsPreSched errh flags apkg = do -- (a path from WF(r1) to CF(r2) implies r1 more urgent than r2) -- For urgency to be computed by paths, we must assume a path from - -- a method's ready signal to its enable signal. - let rdy_to_en_edges = [(PNTopMethodRes rdy_id 1, PNTopMethodEnable m_id) | + -- a method's ready signal to its enable signal. The RDY method has a + -- single output port whose Id matches the method's own Id. + let rdy_to_en_edges = [(PNTopMethodRes rdy_id rdy_id, PNTopMethodEnable m_id) | (AIAction { aif_pred = (ASDef _ rdy_id), - aif_name = m_id, aif_fieldinfo = m_fi }) <- ifc ] ++ - [(PNTopMethodRes rdy_id 1, PNTopMethodEnable m_id) | + aif_name = m_id }) <- ifc ] ++ + [(PNTopMethodRes rdy_id rdy_id, PNTopMethodEnable m_id) | (AIActionValue { aif_pred = (ASDef _ rdy_id), - aif_name = m_id, aif_fieldinfo = m_fi }) <- ifc ] + aif_name = m_id }) <- ifc ] pathgraph' <- addEdgesWithNodes pathgraph rdy_to_en_edges let reachables = findReachables pathgraph' will_fire_nodes @@ -1104,12 +1148,9 @@ aPathsPostSched flags pps apkg pathGraphInfo (ASchedule scheds _) = do Just info -> info Nothing -> internalError ("APaths findMethod: " ++ ppReadable m) - -- the "arg" is already the VName and not a number + -- the "arg" / "res" is already the per-port AId, so no lookup needed let convertArg m arg = aidToVName arg - - let convertRes m res_num = - case (findMethod m) of - (_, res) -> res `genericIndex` (res_num - 1) + convertRes m res = aidToVName res let convertEnable m = case (findMethod m) of @@ -1184,28 +1225,30 @@ connectEdgeR pn pns = map (\x -> (pn, x)) pns mkActionEdges :: PathEnv -> PathNode -> AAction -> [(PathNode, PathNode)] -mkActionEdges env en (ACall state_id qual_meth_id (cond:exprs)) = +mkActionEdges env en (ACall state_id qual_meth_id (cond:srcArgs)) = let meth_id = unQualId qual_meth_id meth_en = PNStateMethodEnable state_id meth_id meth_arg_mux = PNStateMethodArgMux state_id meth_id - meth_args = - map (PNStateMethodArg state_id meth_id) [1..] + argPortPairs = + [ (PNStateMethodArg state_id meth_id argN portM, e) + | (argN, srcArg) <- zip [1..] srcArgs + , (portM, e) <- zip [1..] (argInputPorts srcArg) ] + hasArgPorts = not (null argPortPairs) in -- if the method has arguments, connect the enable signal of the -- action to the control mux for the arguments - (if null exprs then [] else [(en, meth_arg_mux)]) ++ + (if hasArgPorts then [(en, meth_arg_mux)] else []) ++ -- connect the enable of the action to the enable of the method [(en, meth_en)] ++ -- connect the arg expressions to the arguments - concatMap (\(e,pn) -> mkEdgesWithMux en pn e env) - (zip exprs meth_args) ++ + concatMap (\(pn, e) -> mkEdgesWithMux en pn e env) argPortPairs ++ -- connect non-split condition of the call to the enable of the method mkEdgesWithMux en meth_en cond env -mkActionEdges env en (AFCall { aact_args = es@(cond:exprs) }) = +mkActionEdges env en (AFCall { aact_args = es }) = -- XXX right now, we don't track cycles through function calls concatMap (snd3 . findEdges env) es -mkActionEdges env en (ATaskAction { aact_args = es@(cond:exprs) }) = +mkActionEdges env en (ATaskAction { aact_args = es }) = -- XXX right now, we don't track cycles through task calls concatMap (snd3 . findEdges env) es mkActionEdges env en action = @@ -1229,39 +1272,49 @@ findEdges :: PathEnv -> AExpr -> findEdges env (APrim i t op es) = -- make edge between inputs and output concatUnzip3 (map (findEdges env) es) -findEdges env (AMethCall t i qmi exprs) = +findEdges env (AMethCall t i qmi args) = -- make edges between exprs and meth input -- return the output connection let mi = unQualId qmi - -- like mkEdgesWithMux, but want to return the muxes, not connect them - f (n,exp) = let (is, edges, muxes) = findEdges env exp - pn = PNStateMethodArg i mi n - es = edges ++ (connectEdge pn is) - in (es, muxes) - (edges, ms) = concatUnzip (map f (zip [1..] exprs)) + argPortPairs = + [ (PNStateMethodArg i mi argN portM, e) + | (argN, srcArg) <- zip [1..] args + , (portM, e) <- zip [1..] (argInputPorts srcArg) ] + f (pn, e) = let (is, edges, muxes) = findEdges env e + es' = edges ++ connectEdge pn is + in (es', muxes) + (edges, ms) = concatUnzip (map f argPortPairs) meth_arg_mux = PNStateMethodArgMux i mi - muxes = if null exprs then ms else meth_arg_mux:ms + muxes = if null argPortPairs then ms else meth_arg_mux:ms in ([PNStateMethodRes i mi 1], edges, muxes) findEdges env (AMethValue t i qmi) = ([PNStateMethodRes i (unQualId qmi) 1], [], []) -findEdges env (ATupleSel _ (AMethCall t i qmi exprs) oi) = +findEdges env (ATupleSel _ (AMethCall t i qmi args) oi) = -- make edges between exprs and meth input -- return the output connection let mi = unQualId qmi - -- like mkEdgesWithMux, but want to return the muxes, not connect them - f (n,exp) = let (is, edges, muxes) = findEdges env exp - pn = PNStateMethodArg i mi n - es = edges ++ (connectEdge pn is) - in (es, muxes) - (edges, ms) = concatUnzip (map f (zip [1..] exprs)) + argPortPairs = + [ (PNStateMethodArg i mi argN portM, e) + | (argN, srcArg) <- zip [1..] args + , (portM, e) <- zip [1..] (argInputPorts srcArg) ] + f (pn, e) = let (is, edges, muxes) = findEdges env e + es' = edges ++ connectEdge pn is + in (es', muxes) + (edges, ms) = concatUnzip (map f argPortPairs) meth_arg_mux = PNStateMethodArgMux i mi - muxes = if null exprs then ms else meth_arg_mux:ms + muxes = if null argPortPairs then ms else meth_arg_mux:ms in ([PNStateMethodRes i mi oi], edges, muxes) findEdges env (ATupleSel _ (AMethValue t i qmi) oi) = ([PNStateMethodRes i (unQualId qmi) oi], [], []) -findEdges env (ATupleSel _ e _) = - internalError - ("APaths.findEdges: unexpected ATupleSel expression: " ++ ppReadable e) +-- selecting an element of a tuple-binding def reads just that element's node, +-- not the whole def -- this is what keeps the per-element signals distinct +findEdges env (ATupleSel _ (ASDef _ d) oi) + | Just pns <- M.lookup d env, oi >= 1, oi <= genericLength pns = + ([pns `genericIndex` (oi - 1)], [], []) +-- selecting an element of a literal tuple reads just that element +findEdges env (ATupleSel _ (ATuple _ es) oi) + | oi >= 1, oi <= genericLength es = findEdges env (es `genericIndex` (oi - 1)) +findEdges env (ATupleSel _ e _) = findEdges env e findEdges env (ATuple _ es) = -- return any connections found in the element expressions @@ -1279,17 +1332,17 @@ findEdges env (ATaskValue { }) = ([],[],[]) findEdges env (ASPort t i) = case (M.lookup i env) of Nothing -> internalError ("findEdges: unknown ASPort: " ++ ppReadable i) - Just pn -> ([pn],[],[]) + Just pns -> (pns,[],[]) -- module parameter reference findEdges env (ASParam t i) = case (M.lookup i env) of Nothing -> internalError ("findEdges: unknown ASParam: " ++ ppReadable i) - Just pn -> ([pn],[],[]) --- ref to local def + Just pns -> (pns,[],[]) +-- ref to local def (a tuple-binding def contributes all its element nodes) findEdges env (ASDef t i) = case (M.lookup i env) of Nothing -> internalError ("findEdges: unknown ASDef: " ++ ppReadable i) - Just pn -> ([pn],[],[]) + Just pns -> (pns,[],[]) findEdges env (ASInt _ _ _) = ([],[],[]) findEdges env (ASReal _ _ _) = ([],[],[]) findEdges env (ASStr _ _ _) = ([],[],[]) diff --git a/src/comp/ASchedule.hs b/src/comp/ASchedule.hs index de940b265..e9aceb344 100644 --- a/src/comp/ASchedule.hs +++ b/src/comp/ASchedule.hs @@ -2726,24 +2726,22 @@ extractMethodArgEdges scConflictMap0 ds ifs = in S.unions $ map findRulePortUses rs -- Given an interface field, determine if a conflict edge is needed - findAIFaceUses (AIActionValue { aif_name = mid, - aif_value = d, - aif_body = rs, - aif_inputs = as }) = + findAIFaceUses iface@(AIActionValue { aif_name = mid, + aif_value = d, + aif_body = rs }) = -- If the edge already exists, don't bother if G.member (mid, mid) scConflictMap0 then S.empty - else let argset = S.fromList (map fst as) + else let argset = S.fromList (map fst (aIfaceArgs iface)) condset = findACondUses rs valset = findAVValueUses d in S.intersection argset (S.union condset valset) - findAIFaceUses (AIAction { aif_name = mid, - aif_body = rs, - aif_inputs = as }) = + findAIFaceUses iface@(AIAction { aif_name = mid, + aif_body = rs }) = -- If the edge already exists, don't bother if G.member (mid, mid) scConflictMap0 then S.empty - else let argset = S.fromList (map fst as) + else let argset = S.fromList (map fst (aIfaceArgs iface)) condset = findACondUses rs in S.intersection argset condset findAIFaceUses _ = S.empty diff --git a/src/comp/AState.hs b/src/comp/AState.hs index fbfc648d4..787b92a35 100644 --- a/src/comp/AState.hs +++ b/src/comp/AState.hs @@ -677,16 +677,18 @@ genModVars vs omMultMap = allmvars -- and a boolean if it is the enable part (of an action meth) -- (meth_part, portType, isEnable) <- - -- argument triples - [ (MethodArg n, argType, True) -- EWC mark at true for input - | (n, argType) <- zip [1..] argTypes ] ++ + -- argument triples — one per (argN, portM) input port, + -- preserving the source-language grouping of argTypes + [ (MethodArg argN portM, argType, True) + | (argN, typeGroup) <- zip [1..] argTypes + , (portM, argType) <- zip (splitPortNums typeGroup) typeGroup ] ++ -- enable triple (case (en_type) of Nothing -> [] (Just t) -> [(MethodEnable, t, True)]) ++ -- value triple [(MethodResult mn, t, False) - | (mn, t) <- zip (methResultNums val_types) val_types ], + | (mn, t) <- zip (splitPortNums val_types) val_types ], -- uniquifiers for multiple ports -- (if only one copy, then the list just contains 0) ino <- map (toMaybe (mult > 1)) [ 0 .. (getMultUse (modId, methId) - 1) `max` 0 ], @@ -771,7 +773,7 @@ mkSIClockTuple (clk:gates, _) = (clk, gates) mkSIClockTuple x = internalError ("aState mkClockIds: " ++ ppReadable x) mkSIMethodTuple :: AIFace -> [ASPMethodInfo] -mkSIMethodTuple (AIDef name args _ pred _ vfi _) = +mkSIMethodTuple iface@(AIDef name _ _ pred _ vfi _) = let (res, rdy, _) = extractNames vfi in -- assume that method name is the return value Id @@ -780,10 +782,10 @@ mkSIMethodTuple (AIDef name args _ pred _ vfi _) = aspm_mrdyid = Just rdy, aspm_menableid = Nothing, aspm_resultids = res, - aspm_inputs = map fst args, + aspm_inputs = map fst (aIfaceArgs iface), aspm_assocrules = [] } ] -mkSIMethodTuple (AIAction args _ pred name rs vfi) = +mkSIMethodTuple iface@(AIAction _ _ pred name rs vfi) = let (_, rdy, ena) = extractNames vfi in [ASPMethodInfo{ aspm_name = name, @@ -791,10 +793,10 @@ mkSIMethodTuple (AIAction args _ pred name rs vfi) = aspm_mrdyid = Just rdy, aspm_menableid = Just ena, aspm_resultids = [], - aspm_inputs = map fst args, + aspm_inputs = map fst (aIfaceArgs iface), aspm_assocrules = map aRuleName rs } ] -mkSIMethodTuple (AIActionValue args _ pred name rs _ vfi) = +mkSIMethodTuple iface@(AIActionValue _ _ pred name rs _ vfi) = let (res, rdy, ena) = extractNames vfi in [ASPMethodInfo{ aspm_name = name, @@ -802,7 +804,7 @@ mkSIMethodTuple (AIActionValue args _ pred name rs _ vfi) = aspm_mrdyid = Just rdy, aspm_menableid = Just ena, aspm_resultids = res, - aspm_inputs = map fst args, + aspm_inputs = map fst (aIfaceArgs iface), aspm_assocrules = map aRuleName rs } ] mkSIMethodTuple (AIClock {}) = [] @@ -1044,14 +1046,26 @@ mkEmuxs tl cnd rdb value_method_ids om o m ino emrs = -- make a list of, for each argument, a list of the different -- expressions used by the different uses for that argument arg_blobs = transpose [ [ (e, (cnd es), rs) | e <- tl es ] | - (AMethCall _ _ _ es, rs) <- emrs] - - -- Call mkEmux once for each argument of the method, giving it - -- the list of different expressions for that argument, to - -- separately mux the values for each argument. - -- The result is new defs for the connections to the mux. - def_tuples = zipWith (mkEmux rdb value_method_ids om ino o m) - [1..] arg_blobs + (AMethCall _ _ _ args, rs) <- emrs, + let es = concatMap argInputPorts args ] + + -- (argN, portM) coordinates for each input-port position; derived + -- from the first call's args shape (all calls share the same + -- method, hence the same shape). `tl` strips the cond from the + -- args list when called from the action variant. + portCoords = case emrs of + ((AMethCall _ _ _ args, _) : _) -> + [ (argN, portM) + | (argN, arg) <- zip [1..] (tl args) + , (portM, _) <- zip (splitPortNums (argInputPorts arg)) (argInputPorts arg) ] + _ -> [] + + -- Call mkEmux once for each input port of the method, giving it + -- the list of different expressions for that port, to separately + -- mux the values for each. Result: new defs for the mux wiring. + def_tuples = zipWith (\(argN, portM) -> + mkEmux rdb value_method_ids om ino o m argN portM) + portCoords arg_blobs (sel_defs, val_defs, out_defs) = concatUnzip3 def_tuples mkPortSubsts (e, _) = @@ -1090,12 +1104,12 @@ mkEmuxs tl cnd rdb value_method_ids om o m ino emrs = -- * The definition for the output of the mux -- mkEmux :: ExclusiveRulesDB -> [AId] -> OrderMap -> - Maybe Integer -> AId -> AId -> Integer -> + Maybe Integer -> AId -> AId -> Integer -> Maybe Integer -> [(AExpr, AExpr, Maybe [ARuleId])] -> ([ADef], [ADef], [ADef]) -mkEmux exclusive_rules_db value_method_ids om ino o m ano [(e, _, _)] = +mkEmux exclusive_rules_db value_method_ids om ino o m argN portM [(e, _, _)] = -- Only one input to the mux - ([], [], [ ADef (argId ino o m ano) (aType e) e [] ]) -mkEmux exclusive_rules_db value_method_ids om ino o m ano ers@((e,_,_):_) = + ([], [], [ ADef (argId ino o m argN portM) (aType e) e [] ]) +mkEmux exclusive_rules_db value_method_ids om ino o m argN portM ers@((e,_,_):_) = -- Multiple inputs let -- --------------- @@ -1246,7 +1260,7 @@ mkEmux exclusive_rules_db value_method_ids om ino o m ano ers@((e,_,_):_) = sel_defs = concatMap mkSel ers' -- The Id of this argument - i = argId ino o m ano + i = argId ino o m argN portM -- The new def for the result of the mux -- default_pair is an explicit default conditions for the mux ASAny @@ -1266,7 +1280,7 @@ mkEmux exclusive_rules_db value_method_ids om ino o m ano ers@((e,_,_):_) = ppReadable (o, m, map fst3 ers)) else (sel_defs, val_defs, [out_def]) -mkEmux _ _ _ _ _ _ _ _ = internalError "mkEMux" +mkEmux _ _ _ _ _ _ _ _ _ = internalError "mkEMux" -- create a default expresson for a mux from the conditions mkDefaultPair :: AType -> [AExpr] -> [AExpr] @@ -1344,8 +1358,8 @@ mkIdGuards _ _ _ exp = internalError $ "mkIdGuards: " ++ ppReadable exp -- Helper functions -- -argId :: Maybe Integer -> Id -> Id -> Integer -> Id -argId ino o m ano = mkMethId o m ino (MethodArg ano) +argId :: Maybe Integer -> Id -> Id -> Integer -> Maybe Integer -> Id +argId ino o m argN portM = mkMethId o m ino (MethodArg argN portM) aWillFireId :: AId -> AExpr aWillFireId i = ASDef aTBool (mkIdWillFire i) diff --git a/src/comp/ASyntax.hs b/src/comp/ASyntax.hs index b0bd445ad..f66ec9b48 100644 --- a/src/comp/ASyntax.hs +++ b/src/comp/ASyntax.hs @@ -18,6 +18,7 @@ module ASyntax( APred, AIFace(..), AInput, + AMethodInput, AAbstractInput(..), AOutput, AClock(..), @@ -97,7 +98,7 @@ module ASyntax( mkMethStr, mkMethArgStr, mkMethResStr, - methResultNums, + splitPortNums, isMethId, MethodPart(..), getParams, @@ -128,7 +129,7 @@ import Prim import ErrorUtil(internalError) import Backend import Pragma -import PreStrings(fsDollar, fsUnderscore, fsEnable, fs_res) +import PreStrings(fsDollar, fsUnderscore, fsEnable, fs_port) import FStringCompat -- import Position(noPosition) import Position @@ -537,6 +538,11 @@ getArraySize t = internalError ("getArraySize: " ++ ppReadable t) -- then to be AAbstractInput.) type AInput = (AId, AType) +-- One source-language method argument, decomposed into the hardware input +-- ports it occupies (a single port for an unsplit argument, several for a +-- split struct/tuple). A method's arguments are then a list of these groups. +type AMethodInput = [AInput] + -- These are abstract inputs (including inouts), which can map to one or more -- hardware ports. These are used in APackage for module arg inputs, prior to -- being converted to AInput in AState. @@ -547,9 +553,6 @@ data AAbstractInput = AAI_Clock AId (Maybe AId) | AAI_Reset AId | AAI_Inout AId Integer - -- room to add other types here, like: - -- AAI_Struct [(AId, AType)] - -- ... deriving (Eq, Show) instance NFData AAbstractInput where @@ -581,10 +584,11 @@ data AVInst = AVInst { -- XXX This list corresponds to vFields in the VModInfo, but cannot be -- XXX stored there, because VModInfo is created before types are known. -- There is a triple for each method in vFields of VModInfo. - -- The triple contains the types of each argument (in order), maybe - -- the type of the EN, and the return values. + -- The first component lists the types of the ports arising from each + -- method argument. The second is maybe the type of the EN, and the + -- third is the types of the output ports arising from the method result. -- NOTE: These are the output language types (i.e. ATBit n) - avi_meth_types :: [([AType], Maybe AType, [AType])], + avi_meth_types :: [([[AType]], Maybe AType, [AType])], -- This field maps source-language types to their corresponding ports avi_port_types :: M.Map VName IType, avi_vmi :: VModInfo, -- Verilog names, conflict info, etc. @@ -784,7 +788,7 @@ instance NFData AAssumption where -- the APred is the implicit condition to the scheduler data AIFace = AIDef { aif_name :: AId, - aif_inputs :: [AInput], + aif_inputs :: [AMethodInput], aif_props :: WireProps, aif_pred :: APred, aif_value :: ADef, @@ -792,13 +796,13 @@ data AIFace = AIDef { aif_name :: AId, -- value methods have their own assumptions -- because there is no rule to attach it to aif_assumps :: [AAssumption] } - | AIAction { aif_inputs :: [AInput], + | AIAction { aif_inputs :: [AMethodInput], aif_props :: WireProps, aif_pred :: APred, aif_name :: AId, aif_body :: [ARule], aif_fieldinfo :: VFieldInfo } - | AIActionValue { aif_inputs :: [AInput], + | AIActionValue { aif_inputs :: [AMethodInput], aif_props :: WireProps, aif_pred :: APred, aif_name :: AId, @@ -852,11 +856,18 @@ aIfaceResIds (AIDef {aif_name=id}) = [id] aIfaceResIds (AIActionValue {aif_name=id}) = [id] aIfaceResIds _ = [] +-- Source-language argument groups (each group is one method argument, which +-- may decompose to multiple hardware ports). +aIfaceArgGroups :: AIFace -> [AMethodInput] +aIfaceArgGroups (AIClock {}) = [] +aIfaceArgGroups (AIReset {}) = [] +aIfaceArgGroups (AIInout {}) = [] +aIfaceArgGroups f = aif_inputs f + +-- Flat list of hardware-level input ports, in order, expanding multi-port +-- argument groups. aIfaceArgs :: AIFace -> [AInput] -aIfaceArgs (AIClock {}) = [] -aIfaceArgs (AIReset {}) = [] -aIfaceArgs (AIInout {}) = [] -aIfaceArgs f = aif_inputs f +aIfaceArgs = concat . aIfaceArgGroups -- associate the internal and external names and width of AIFace args @@ -864,9 +875,10 @@ aiface_argnames_width :: AIFace -> [(AId, String, Integer)] aiface_argnames_width (AIClock {}) = [] aiface_argnames_width (AIReset {}) = [] aiface_argnames_width aif = - zip3 (map fst (aif_inputs aif)) - (map (getVNameString . fst) (vf_inputs (aif_fieldinfo aif))) - (map aIfaceArgSize (aif_inputs aif)) + let ports = aIfaceArgs aif + in zip3 (map fst ports) + (map (getVNameString . fst) (vfMethodArgPorts (aif_fieldinfo aif))) + (map aIfaceArgSize ports) aIfaceArgSize :: AInput -> Integer @@ -1037,7 +1049,10 @@ data AExpr ae_type :: AType, ae_objid :: AId, ameth_id :: AMethodId, - ae_args :: [AExpr] -- external state method call + -- external state method call: one AExpr per source argument + -- (a SplitPorts arg arrives as an ATuple AExpr; consumers that + -- walk individual hardware ports match on ATuple). + ae_args :: [AExpr] } -- like AMethCall, but for the return value of actionvalue methods, -- where the return value no longer has to care about the arguments, @@ -1260,9 +1275,11 @@ data ANoInlineFun = String -- numeric types [Integer] - -- port list (inputs,outputs), each is port name and size - -- XXX sizes all seem to be generated as 0. - ([(String, Integer)], [(String, Integer)]) + -- port list (inputs, outputs); each port is its name and bit size. + -- Inputs are grouped per argument (the inner list is one argument's + -- ports, of which there may be several when the argument splits); the + -- outputs are a flat list (the single result, possibly split).] + ([[(String, Integer)]], [(String, Integer)]) -- when an instance name is assigned to the call, it is stored here (Maybe String) deriving (Eq, Ord, Show) @@ -1448,7 +1465,7 @@ instance PPrint AIFace where -- XXX print assumptions pPrint d p ai@(AIDef {} ) = (text "--AIDef" <+> pPrint d p (aif_name ai)) $+$ - foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ + foldr (($+$) . ppV d) empty (aIfaceArgs ai) $+$ pPrint d p (aif_value ai) $+$ pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ @@ -1456,7 +1473,7 @@ instance PPrint AIFace where text "" pPrint d p ai@(AIAction {} ) = (text "--AIAction" <+> pPrint d p (aif_name ai)) $+$ - foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ + foldr (($+$) . ppV d) empty (aIfaceArgs ai) $+$ pPrint d p (aif_body ai) $+$ pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ @@ -1464,7 +1481,7 @@ instance PPrint AIFace where text "" pPrint d p ai@(AIActionValue {}) = -- XXX this should be done better (text "--AIActionValue" <+> pPrint d p (aif_name ai)) $+$ - foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ + foldr (($+$) . ppV d) empty (aIfaceArgs ai) $+$ pPrint d p (aif_value ai) $+$ pPrint d p (aif_body ai) $+$ pPred d p (aif_pred ai) $+$ @@ -1740,18 +1757,19 @@ ppeVTI m d (vi, es, ns) = instance PPrintExpand AIFace where -- XXX print assumptions - pPrintExpand m d ec (AIDef id is wp g b _ _) = + pPrintExpand m d ec ai@(AIDef id _ wp g b _ _) = (text "--" <+> pPrint d (getP ec) g) $+$ - foldr (($+$) . ppV d) (pPrint d (getP ec) b) is $+$ + foldr (($+$) . ppV d) (pPrint d (getP ec) b) (aIfaceArgs ai) $+$ text "" - pPrintExpand m d ec (AIAction is wp g _ rs _) = + pPrintExpand m d ec ai@(AIAction _ wp g _ rs _) = (text "--" <+> pPrint d (getP ec) g) $+$ - foldr (($+$) . ppV d) (pPrintExpand m d ec rs) is $+$ + foldr (($+$) . ppV d) (pPrintExpand m d ec rs) (aIfaceArgs ai) $+$ text "" - pPrintExpand m d ec (AIActionValue is wp g _ rs b _) = + pPrintExpand m d ec ai@(AIActionValue _ wp g _ rs b _) = + let args = aIfaceArgs ai in (text "--" <+> pPrint d (getP ec) g) $+$ - foldr (($+$) . ppV d) (pPrintExpand m d ec rs) is $+$ - foldr (($+$) . ppV d) (pPrint d (getP ec) b) is $+$ + foldr (($+$) . ppV d) (pPrintExpand m d ec rs) args $+$ + foldr (($+$) . ppV d) (pPrint d (getP ec) b) args $+$ text "" pPrintExpand m d ec (AIClock i c _) = pPrint d (getP ec) c pPrintExpand m d ec (AIReset i r _) = pPrint d (getP ec) r @@ -1875,7 +1893,8 @@ instance PPrintExpand AExpr where docArgs = map (pPrintExpand m d defContext) es pPrintExpand m d ec (AMethValue _ i meth) = pPrint d 1 i <> text "." <> ppMethId d meth pPrintExpand m d ec (ATuple _ es) = parens (commaSep (map (pPrintExpand m d defContext) es)) - pPrintExpand m d ec (ATupleSel _ e idx) = (pparen (useParen ec) $ pPrintExpand m d defContext e) <> text ("[" ++ itos idx ++ "]") + pPrintExpand m d ec (ATupleSel _ e idx) = + pPrintExpand m d pContext e <> text ("[" ++ itos idx ++ "]") pPrintExpand m d ec (ASPort _ i) = pPrint d (getP ec) i pPrintExpand m d ec (ASParam _ i) = pPrint d (getP ec) i pPrintExpand m d ec (ASDef _ i) | isIdWillFire i && (lookupLevel m) > 0 || @@ -1906,23 +1925,28 @@ defLookup d ped = M.findWithDefault err d (defmap ped) -- # Some standardized methods for making (default) method strings -- ############################################################################# data MethodPart = - MethodArg Integer | -- argument 1, 2, ... input - MethodResult (Maybe Integer) | -- return value: Nothing for a single result, - -- Just 1, 2, ... when split across ports - MethodEnable -- enable signal input + -- Source argument index (1-based) and, when the argument is split across + -- several hardware ports (e.g. a SplitPorts tuple), the port index within + -- that argument (Just 1, 2, ...). An un-split argument has Nothing. + MethodArg Integer (Maybe Integer) | + -- return value: Nothing for a single (un-split) result, Just 1, 2, ... + -- when the result is split across multiple output ports + MethodResult (Maybe Integer) | + MethodEnable -- enable signal input deriving (Eq) -- The method syntax is as follows: --- Arguments are $_ starting from 1 --- (e.g. the_fifo$enq_1) --- Return values are $_RES_ when the result is split across --- multiple output ports (e.g. the_fifo$first_RES_1), or just $ --- when the method has a single result (e.g. the_fifo$first) +-- Arguments are $_ starting from 1 (e.g. the_fifo$enq_1). +-- When an argument is split across several hardware ports, each port gets +-- an extra _PORT_ suffix (e.g. the_fifo$enq_1_PORT_1). +-- Return values are just $ for a single result +-- (e.g. the_fifo$first); when the result is split across several output +-- ports, each gets a _PORT_ suffix (e.g. the_fifo$first_PORT_1). -- Enable signals are $EN_ (e.g. the_fifo$EN_enq) --- Multi-ported methods are $__ --- or $__RES_ --- The portnum is only omitted if the method has one or --- and infinite number of ports (like a register) +-- Methods with multiplicity > 1 prefix the above with the copy number, +-- $__... +-- The copynum is only omitted if the method has one or +-- an infinite number of ports (like a register) -- XXX these should probably just be a data type rather than Ids mkMethId :: Id -> Id -> Maybe Integer -> MethodPart -> Id mkMethId o m ino mp = @@ -1948,7 +1972,7 @@ mkMethStr obj m m_port mp = fsUnderscore, mkNumFString port] base = case mp of - MethodArg n -> mkMethArgStr meth_port n + MethodArg argN portM -> mkMethArgStr meth_port argN portM MethodResult mn -> mkMethResStr meth_port mn MethodEnable -> -- XXX are we overloading fsEnable? @@ -1958,26 +1982,33 @@ mkMethStr obj m m_port mp = fsDollar, base] -mkMethArgStr :: FString -> Integer -> FString -mkMethArgStr meth_port n = - if (n == 0) +-- An argument is named _. When the argument is split across +-- multiple hardware ports, each port gets an extra _PORT_ suffix. +mkMethArgStr :: FString -> Integer -> Maybe Integer -> FString +mkMethArgStr meth_port argN mPortM = + if (argN == 0) then internalError "mkMethArgStr" - else concatFString [meth_port, fsUnderscore, mkNumFString n] + else concatFString ([meth_port, fsUnderscore, mkNumFString argN] ++ + portSuffix mPortM) +-- A single (un-split) result is just ; when the result is split across +-- multiple output ports, each port gets a _PORT_ suffix. mkMethResStr :: FString -> Maybe Integer -> FString --- a single result gets no _RES_ suffix -mkMethResStr meth_port Nothing = meth_port -mkMethResStr meth_port (Just n) = - if (n == 0) - then internalError "mkMethResStr" - else concatFString [meth_port, fsUnderscore, fs_res, mkNumFString n] - --- The result numbers for a method with the given list of results: Nothing --- (no _RES_ suffix) for a single result, Just 1, Just 2, ... when split across --- multiple output ports. -methResultNums :: [a] -> [Maybe Integer] -methResultNums [_] = [Nothing] -methResultNums xs = zipWith (\ _ n -> Just n) xs [1..] +mkMethResStr meth_port mPortM = concatFString (meth_port : portSuffix mPortM) + +-- The _PORT_ suffix for a split input/output port (empty when not split) +portSuffix :: Maybe Integer -> [FString] +portSuffix Nothing = [] +portSuffix (Just n) = if (n == 0) + then internalError "portSuffix" + else [fsUnderscore, fs_port, mkNumFString n] + +-- Port numbers for an input/output split across the given list of hardware +-- ports: Nothing (no _PORT_ suffix) for a single port, Just 1, Just 2, ... +-- when split across several. +splitPortNums :: [a] -> [Maybe Integer] +splitPortNums [_] = [Nothing] +splitPortNums xs = zipWith (\ _ n -> Just n) xs [1..] -- ############################################################################# -- # diff --git a/src/comp/ASyntaxUtil.hs b/src/comp/ASyntaxUtil.hs index a12b6580d..89954b44a 100644 --- a/src/comp/ASyntaxUtil.hs +++ b/src/comp/ASyntaxUtil.hs @@ -11,7 +11,7 @@ import PPrint import IntLit import SCC(tsort) import Util(separate) -import Data.List(nub) +import Data.List(nub, genericIndex, genericDrop) import Data.Maybe(mapMaybe, fromMaybe) import Id(Id) import Control.Monad(liftM) @@ -253,6 +253,28 @@ instance ATypeC ADef where aType d = adef_type d aSize d = aSize $ adef_type d +-- The bit range [hi:lo] occupied by element `idx` (1-based) of a tuple type, +-- whose elements are laid out with the first in the most-significant position. +-- Shared by the Verilog (ATupleSel -> bit-slice) and Bluesim (ATupleSel -> +-- extract) lowerings so they stay in sync. +tupleElemRange :: AType -> Integer -> (Integer, Integer) +tupleElemRange (ATTuple ts) idx = + let sizes = map aSize ts + lo = sum (genericDrop idx sizes) -- bits below the element + hi = lo + (sizes `genericIndex` (idx - 1)) - 1 + in (hi, lo) +tupleElemRange t _ = + internalError ("tupleElemRange: not a tuple type: " ++ ppReadable t) + + +-- --------------- + +-- Return the AExprs that drive the input ports for a method argument. +argInputPorts :: AExpr -> [AExpr] +argInputPorts (ATuple _ es) = es +argInputPorts e = case aType e of + ATTuple ts -> [ ATupleSel t e idx | (idx, t) <- zip [1..] ts ] + _ -> [e] -- --------------- diff --git a/src/comp/AVerilogUtil.hs b/src/comp/AVerilogUtil.hs index c8f245233..048529b2b 100644 --- a/src/comp/AVerilogUtil.hs +++ b/src/comp/AVerilogUtil.hs @@ -31,8 +31,8 @@ module AVerilogUtil ( VConvtOpts(..) ) where -import Data.List(nub, partition, genericLength, union, intersect, (\\), - uncons) +import Data.List(nub, partition, genericLength, genericIndex, union, intersect, + (\\), uncons) import Data.Maybe import FStringCompat(FString, getFString) @@ -520,34 +520,43 @@ vDefMpd vco def@(ADef i t (APrim _ _ PrimMux es) _) _ = vDefMpd vco (ADef i t (ANoInlineFunCall _ _ (ANoInlineFun n is (ips, ops) (Just inst_name)) es) _) _ = - let ops' = ops -- filter (\(x,y) -> y >= 0 ) $ traces ("ops " ++ show ops) ops - -- Size information all appears to be 0 - (ips',es') = unzip $ filter (isNotZeroSized . ae_type . snd) (zip ips es) - oname = VEVar (vId i) -- a concat of the outputs - oports = case ops' of - [(o, _)] -> [(mkVId o, Just oname)] - ons -> let ns = tailOrErr "vDefMpd.oports" (scanr (+) 0 (map snd ons)) - in zipWith (\ (o, s) l -> - (mkVId o, - Just (veSelect - oname - (VEConst (l+s-1)) - (VEConst l)))) - ons - ns + let + -- connect the result and each argument to their (split) ports + oports = connectTuplePorts vco (ASDef t i) ops + (iwires, iports) = mkInputs (0 :: Integer) (zip es ips) + -- A tuple result is declared as one wire per element (which the + -- instance's split output ports drive directly via connectTuplePorts + -- and the type-based ATupleSel lowering); anything else is one wire. + resultDecls = case t of + ATTuple ts -> [ VMDecl $ VVDecl VDWire (vSize tk) + [VVar (tupleElemVId i k)] + | (k, tk) <- zip [1..] ts ] + _ -> [VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)]] in - [ VMDecl $ VVDecl VDWire (vSize t) [VVar (vId i)], - VMInst { + iwires ++ + resultDecls ++ + [ VMInst { vi_module_name = mkVId n, vi_inst_name = VId inst_name i Nothing, -- these are size params, so default width of 32 is fine vi_inst_params = Left (map (\x -> (Nothing,VEConst x)) is), - vi_inst_ports = (zip - (map (mkVId . fst) ips') - (map (Just . (vExpr vco)) es') - ++ oports) + vi_inst_ports = iports ++ oports } ] + where + -- An argument that can't be selected in place (not a variable or literal + -- tuple, e.g. a bare concat) is bound to a wire _arg_ first. + mkInputs _ [] = ([], []) + mkInputs k ((e, pts):rest) = + let (wires, base) + | length pts <= 1 || isSelectable e = ([], e) + | otherwise = + let aid = setIdBaseString i (inst_name ++ "_arg_" ++ itos k) + in ([VMDecl (VVDWire (vSize (ae_type e)) (VVar (vId aid)) (vExpr vco e))], + ASDef (ae_type e) aid) + conns = connectTuplePorts vco base pts + (wires', conns') = mkInputs (k+1) rest + in (wires ++ wires', conns ++ conns') vDefMpd vco defin@(ADef i t (APrim _ _ PrimCase es@(x:defarm:ces_t)) _) _ = [ VMDecl $ VVDecl VDReg (vSize t) [VVar vi], @@ -605,14 +614,80 @@ vDefMpd vco adef@(ADef i_t t_t@(ATAbstract aid _) e_t _) _ | aid==idInout_ = [VMDecl $ VVDWire (vSize t_t) (VVar (vId i_t)) (vExpr vco e_t)] vDefMpd vco adef@(ADef i_t t_t@(ATString _) e_t _) _ = [VMDecl $ VVDWire (vSize t_t) (VVar (vId i_t)) (vExpr vco e_t)] +-- A tuple-typed def is emitted as one wire per element, so that an ATupleSel +-- references the element wire (vExpr) instead of slicing. (A noinline tuple +-- result is handled by the ANoInlineFunCall clause above, which declares +-- per-element wires that the instance drives directly.) +-- +-- A literal tuple uses its element expressions directly: +vDefMpd vco (ADef i (ATTuple ts) (ATuple _ es) _) _ = + [ VMDecl $ VVDWire (vSize t) (VVar (tupleElemVId i k)) (vExpr vco e) + | (k, t, e) <- zip3 [1..] ts es ] +-- Any other tuple-typed def is an invariant violation: tuples reach codegen +-- only as literals (above) or as noinline results (the ANoInlineFunCall clause, +-- which declares per-element wires the instance drives directly). +vDefMpd _ adef@(ADef _ (ATTuple _) _ _) _ = + internalError ("AVerilog::vDefMpd: non-literal/non-noinline tuple def: " ++ ppReadable adef) vDefMpd vco adef@(ADef _ _ _ _) _ = internalError( "unexpected pattern in AVerilog::vDefMpd: " ++ ppReadable adef ) ; -- ------------------------------ - -veSelect :: VExpr -> VExpr -> VExpr -> VExpr -veSelect e h l = if h == l then VESelect1 e l else VESelect e h l +-- Connecting a tuple-typed value to a flat list of split ports. + +-- Connect each port to the matching part of a tuple value by walking its +-- (right-nested) tuple type with ATupleSel, which vExpr lowers by selecting a +-- literal element directly or slicing a variable (composing via vSelectBits) -- +-- so a Verilog concatenation is never bit-sliced by hand. Reusable by any pass +-- that wires a tuple-typed value to a flat list of sized ports. +connectTuplePorts :: VConvtOpts -> AExpr -> [(String, Integer)] -> [(VId, Maybe VExpr)] +connectTuplePorts vco val pts = + [ (mkVId o, Just (vExpr vco (tupleSelPath val path))) + | (path, (o, _)) <- portFrontier (ae_type val) pts ] + +-- Match the flat port list to the tuple structure. A single port takes the +-- whole value (its recorded width may be a placeholder, e.g. 0 for a polymorphic +-- foreign function); otherwise split the ports among the tuple's elements by +-- width, so a shallow split stops at the top level and a deep split reaches the +-- leaves. +portFrontier :: AType -> [(String, Integer)] -> [([Integer], (String, Integer))] +portFrontier _ [] = [] +portFrontier _ [p] = [([], p)] +portFrontier (ATTuple ts) pts = + concat $ zipWith (\ idx (t', ps) -> [ (idx:path, p) + | (path, p) <- portFrontier t' ps ]) + [1 ..] (splitByTupleWidth ts pts) +portFrontier ty pts = + internalError ("AVerilogUtil.portFrontier: " ++ ppReadable (ty, pts)) + +-- Split the flat port list so that group i has total width = aSize (ts !! i). +splitByTupleWidth :: [AType] -> [(String, Integer)] + -> [(AType, [(String, Integer)])] +splitByTupleWidth [] _ = [] +splitByTupleWidth (t':ts') pts = + let (grp, rest) = takeWidth (aSize t') pts + in (t', grp) : splitByTupleWidth ts' rest + where takeWidth 0 ps = ([], ps) + takeWidth _ [] = ([], []) + takeWidth w (p:ps) = let (g, r) = takeWidth (w - snd p) ps + in (p:g, r) + +-- Apply a selector path (1-based ATupleSel indices) to a tuple value. +tupleSelPath :: AExpr -> [Integer] -> AExpr +tupleSelPath val [] = val +tupleSelPath val (idx:rest) = + case ae_type val of + ATTuple ts -> tupleSelPath (ATupleSel (ts `genericIndex` (idx-1)) val idx) rest + ty -> internalError ("AVerilogUtil.tupleSelPath: " ++ ppReadable ty) + +-- A variable (sliceable) or literal tuple (element-selectable) can be selected +-- from in place; anything else must be bound to a wire first. +isSelectable :: AExpr -> Bool +isSelectable (ATuple {}) = True +isSelectable (ASDef {}) = True +isSelectable (ASPort {}) = True +isSelectable (ASParam {}) = True +isSelectable _ = False -- ============================== @@ -638,6 +713,11 @@ suff (VId is i m) s = VId (is ++ s) i m pref :: String -> VId -> VId pref p (VId is i m) = VId (p ++ is) i m +-- The wire name for element `idx` (1-based) of a tuple-typed def that has been +-- split into one wire per element. Both the def declaration (vDefMpd) and the +-- references to it (vExpr) must agree on this name. +tupleElemVId :: AId -> Integer -> VId +tupleElemVId i idx = suff (vId i) ("_" ++ itos idx) -- ============================== -- main conversion for AExpr to VExpr @@ -663,11 +743,11 @@ vExpr vco (APrim _ t PrimZeroExt [e]) = 0, vExpr vco e] vExpr vco (APrim _ t PrimSignExt [e]) | aSize e == 1 && aSize t > 0 = VERepeat (VEConst (aSize t)) (vExpr vco e) -vExpr vco e0@(APrim _ t PrimSignExt [e]) = VEConcat [vERepeat fill (VESelect1 vexp vhi), vexp] +-- Replicate the sign bit. +vExpr vco e0@(APrim _ t PrimSignExt [e]) = VEConcat [vERepeat fill (VESelect1 vexp (VEConst (j-1))), vexp] where fill = if (j >= i) then internalError("AVerilogUtil.broken SignExtend: " ++ ppReadable e0) else i-j - vhi = VEConst (j-1) vexp = vExpr vco e i = aSize t j = aSize e @@ -690,11 +770,28 @@ vExpr vco (AFunCall _ _ n isC es) = vExpr vco (ASInt idt (ATBit w) (IntLit _ b i)) = VEWConst (idToVId idt) w b i vExpr vco (ASReal _ _ r) = VEReal r vExpr vco (ASStr _ _ s) = VEString s +-- The only ATuple nodes are built during I->A conversion from tuples of port values. +-- Every such ATuple is consumed by element selection or split into one wire per element +-- (vDefMpd), so a whole tuple never reaches vExpr as a value. +vExpr vco (ASDef (ATTuple ts) i) = + internalError ("vExpr: whole tuple def reached codegen: " ++ ppReadable (i, ts)) vExpr vco (ASDef _ i) = VEVar (vId i) vExpr vco (ASPort _ i) = VEVar (vId i) vExpr vco (ASParam _ i) = VEVar (vId i) vExpr vco (ASAny (ATBit w) _) = VEUnknown w (vco_unspec vco) +-- See above: a reassembled ATuple is always element-selected or split into +-- per-element wires, so a whole ATuple never reaches vExpr -- this is an +-- invariant check. +vExpr vco (ATuple _ es) = + internalError ("vExpr: tuple reached codegen as a value: " ++ ppReadable es) + +-- Similarly, we should only see ATupleSel over a literal tuple or a tuple def. +vExpr vco (ATupleSel _ (ATuple _ es) idx) = vExpr vco (es `genericIndex` (idx - 1)) +vExpr vco (ATupleSel _ (ASDef _ i) idx) = VEVar (tupleElemVId i idx) +vExpr _ (ATupleSel _ e _) = + internalError ("vExpr: ATupleSel over non-literal/non-def base: " ++ ppReadable e) + vExpr vco e = internalError ("vExpr vco " ++ ppReadable e) vXor :: VExpr -> VExpr -> VExpr @@ -857,8 +954,9 @@ vState flags rewire_map avinst = -- Below, we construct info on the method: -- arguments, return values, and enables - mkArgId :: Id -> Integer -> Maybe Integer -> VId - mkArgId m k m_port = vMethId v_inst_name m m_port (MethodArg k) port_rename_table + mkArgId :: Id -> Integer -> Maybe Integer -> Maybe Integer -> VId + mkArgId m argN portM m_port = + vMethId v_inst_name m m_port (MethodArg argN portM) port_rename_table mkEnId m m_port = vMethId v_inst_name m m_port MethodEnable port_rename_table @@ -884,14 +982,21 @@ vState flags rewire_map avinst = -- the size if it is not 1-bit inps :: [(VId, VId, Maybe VRange)] inps = [ (mkVId (portid s ino), - mkArgId m k ino, + mkArgId m argN portM ino, vSize argType) | (meth@(Method m _ _ mult ps outs me), - (argTypes,_,_)) + (argTypeGroups,_,_)) <- zip (vFields vi) mts, - -- let multu = getMethodMultUse m, ino <- if mult > 1 then map Just [0..mult-1] else [Nothing], - (VName s, argType, k) <- zip3 (map fst ps) argTypes [1..], + -- one (vname, type) per input port, paired with its + -- (argN, portM) coordinates in the source argument list + (s, argType, argN, portM) <- + [ (s, t, argN, portM) + | (argN, portGroup, typeGroup) <- + zip3 [1..] ps argTypeGroups + , (portM, (VName s, _), t) <- + zip3 (splitPortNums portGroup) portGroup typeGroup + ], isNotZeroSized argType ] @@ -925,7 +1030,7 @@ vState flags rewire_map avinst = mkResId m k ino) | ((Method m _ _ mult ss outs me), (_,_,retTypes)) <- zip (vFields vi) mts, - ((VName s, vps), retType, k) <- zip3 outs retTypes (methResultNums outs), + ((VName s, vps), retType, k) <- zip3 outs retTypes (splitPortNums outs), isNotZeroSized retType, -- let multu = getMethodMultUse m, ino <- if mult > 1 then map Just [0..mult-1] else [Nothing] @@ -1044,6 +1149,8 @@ vSize (ATAbstract i [1]) | i==idInout_ = Nothing vSize (ATAbstract i [n]) | i==idInout_ = Just (VEConst (n-1), VEConst 0) vSize t@(ATString (Just _)) = Just (VEConst ((aSize t)-1::Integer), VEConst 0) vSize (ATString Nothing) = Just (VEConst (dummy_string_size - 1::Integer), VEConst 0) +-- A tuple is represented as a bit-concat of its elements. +vSize t@(ATTuple _) = Just (VEConst (aSize t - 1), VEConst 0) vSize t = internalError("Attempt to get size of non-Bit type: " ++ ppReadable t) -- Looks at VRange to determine if Verilog expression is 0 size [-1:0] yuck. @@ -1083,6 +1190,8 @@ aIds (APrim _ _ _ es) = concatMap aIds es -- aIds (AMethValue _ i m) = [(vMethId i m 1 MethodResult M.Empty)] aIds (ANoInlineFunCall _ _ _ es) = concatMap aIds es aIds (AFunCall _ _ _ _ es) = concatMap aIds es +aIds (ATupleSel _ (ATuple _ es) idx) = aIds (es `genericIndex` (idx - 1)) +aIds (ATupleSel _ (ASDef _ i) idx) = [tupleElemVId i idx] aIds (ASPort _ i) = [vId i] aIds (ASParam _ i) = [vId i] aIds (ASDef _ i) = [vId i] diff --git a/src/comp/BackendNamingConventions.hs b/src/comp/BackendNamingConventions.hs index ae1aae952..8519e46b7 100644 --- a/src/comp/BackendNamingConventions.hs +++ b/src/comp/BackendNamingConventions.hs @@ -95,7 +95,7 @@ rwireHasId = mkId noPosition (mkFString rwireHasStr) rwireSetEnId, rwireSetArgId, rwireGetResId, rwireHasResId :: Id -> Id rwireSetEnId i = mkMethId i rwireSetId Nothing MethodEnable -rwireSetArgId i = mkMethId i rwireSetId Nothing (MethodArg 1) +rwireSetArgId i = mkMethId i rwireSetId Nothing (MethodArg 1 Nothing) rwireGetResId i = mkMethId i rwireGetId Nothing (MethodResult Nothing) rwireHasResId i = mkMethId i rwireHasId Nothing (MethodResult Nothing) @@ -136,7 +136,7 @@ cregWriteId n = mkId noPosition (mkFString (cregWriteStr n)) cregReadResId, cregWriteEnId, cregWriteArgId :: Id -> Int -> Id cregReadResId i n = mkMethId i (cregReadId n) Nothing (MethodResult Nothing) cregWriteEnId i n = mkMethId i (cregWriteId n) Nothing MethodEnable -cregWriteArgId i n = mkMethId i (cregWriteId n) Nothing (MethodArg 1) +cregWriteArgId i n = mkMethId i (cregWriteId n) Nothing (MethodArg 1 Nothing) -- --------------- -- Names of ports and parameters on primtive CReg @@ -353,7 +353,7 @@ regWriteId pos = mkId pos (mkFString regWriteStr) regReadResId, regWriteEnId, regWriteArgId :: Id -> Id regReadResId i = mkMethId i (regReadId noPosition) Nothing (MethodResult Nothing) regWriteEnId i = mkMethId i (regWriteId noPosition) Nothing MethodEnable -regWriteArgId i = mkMethId i (regWriteId noPosition) Nothing (MethodArg 1) +regWriteArgId i = mkMethId i (regWriteId noPosition) Nothing (MethodArg 1 Nothing) regSchedInfo :: SchedInfo Id regSchedInfo = @@ -383,12 +383,12 @@ cregToReg old_avi = = let nm' = regReadId (getPosition nm) res' = updVPort qoutPortName res in Just (Method nm' c r m [] [res'] Nothing, ts) - convField (Method nm c r m [arg] [] (Just en), ts) + convField (Method nm c r m [[arg]] [] (Just en), ts) | (nm == cregWriteId 0) = let nm' = regWriteId (getPosition nm) arg' = updVPort dinPortName arg en' = updVPort enPortName en - in Just (Method nm' c r m [arg'] [] (Just en'), ts) + in Just (Method nm' c r m [[arg']] [] (Just en'), ts) convField _ = Nothing in unzip $ mapMaybe convField $ @@ -559,7 +559,7 @@ createMapForVMod inst_id (Method meth_id _ _ mult ins outs me) = -- trace (ppRea -- mkMethId in ASyntax -- the two lists should be the same length (this is checked) createMapForOneMeth :: Id -> Integer -> - [VPort] -> [VPort] -> Maybe VPort -> + [[VPort]] -> [VPort] -> Maybe VPort -> ([FString],[FString]) createMapForOneMeth meth_id mult ins outs me = if check then -- trace (ppReadable (method_names, verilog_names)) $ @@ -575,16 +575,22 @@ createMapForOneMeth meth_id mult ins outs me = if check then else [ concatFString [meth_fstr, fsUnderscore, mkNumFString n] | n <- [0 .. mult-1] ] - -- for method "x", make the names "x_ARG_1, x_ARG_2, .." for the ports - -- make the names x__ARG_n for multi-ported methods - method_input_names = [ mkMethArgStr meth_n (toInteger arg_n) | - meth_n <- meth_mult, arg_n <- [1 .. length ins]] + -- For method "x", names are "x_" (plus a "_PORT_" suffix + -- when an argument is split across several ports) — one entry per + -- hardware port, preserving the source-arg grouping. For methods + -- with multiplicity > 1, the meth_n in meth_mult already has the + -- copy-number suffix folded in. + method_input_names = + [ mkMethArgStr meth_n argN portM + | meth_n <- meth_mult + , (argN, ports) <- zip [1 :: Integer ..] ins + , (portM, _) <- zip (splitPortNums ports) ports ] -- the Verilog port names for the above - verilog_input_names = map getFStringForVerilogPair ins + verilog_input_names = map getFStringForVerilogPair (concat ins) -- names for the output ports method_output_names = [ mkMethResStr meth_n out_n | - meth_n <- meth_mult, out_n <- methResultNums outs] + meth_n <- meth_mult, out_n <- splitPortNums outs] -- the Verilog port names for the above verilog_output_names = map getFStringForVerilogPair outs @@ -603,19 +609,16 @@ createMapForOneMeth meth_id mult ins outs me = if check then method_enable_names ++ method_output_names - verilog_names_pre_mult = - verilog_input_names ++ - verilog_enable_name ++ - verilog_output_names - - -- handle the multiplicity for verilog names here - -- note how we go from 1..mult instead of 0..mult-1 - -- as the method side does - verilog_names = if (mult <= 1) - then verilog_names_pre_mult - else [concatFString [fs, fsUnderscore, (mkNumFString (toInteger n))] | -- PORT_N - fs <- verilog_names_pre_mult, - n <- [1..mult]] + -- expand each section with the multiplicity copy as the outer loop and + -- the ports inner, to match method_names and AVerilogUtil's "inps". + -- (Copies number 1..mult here, but 0..mult-1 on the method side.) + multCopies names = if (mult <= 1) + then names + else [ concatFString [fs, fsUnderscore, mkNumFString n] + | n <- [1..mult], fs <- names ] + verilog_names = multCopies verilog_input_names ++ + multCopies verilog_enable_name ++ + multCopies verilog_output_names -- XXX what is going on here?! can someone add a comment? getFStringForVerilogPair :: (VName, [VeriPortProp]) -> FString diff --git a/src/comp/CSyntax.hs b/src/comp/CSyntax.hs index 9098c5a1b..6a8bc241d 100644 --- a/src/comp/CSyntax.hs +++ b/src/comp/CSyntax.hs @@ -1312,7 +1312,7 @@ instance PPrint CExpr where t "inout_field " <> ppVarId d i <+> t p <+> mfi "clocked_by" mc <+> mfi "reset_by" mr f (Method i mc mr n ps os me) = - ppVarId d i <> g n <+> t "=" <+> t (unwords (map h ps)) <+> + ppVarId d i <> g n <+> t "=" <+> t (unwords (map h (concat ps))) <+> mfi "clocked_by" mc <+> mfi "reset_by" mr <+> (if null os then empty else t"output" <+> t (unwords (map h os))) <+> mfp "enable" me diff --git a/src/comp/CVPrint.hs b/src/comp/CVPrint.hs index 3c7dc29ff..85538e315 100644 --- a/src/comp/CVPrint.hs +++ b/src/comp/CVPrint.hs @@ -865,7 +865,7 @@ ppVeriMethod d mr (Method i mc mreset n pts os me) = _ -> t"(" <> sepList (map (f "" " " . Just) os) (t",") <> t")") <> (pvpId d i <> (if n == 1 then empty else (t"[" <> (pp d n) <> t"]")) <> - (t"(" <> sepList (map (f "" "" . Just) pts) (t",") <> t")") <> + (t"(" <> sepList (map (f "" "" . Just) (concat pts)) (t",") <> t")") <> (f " enable (" ")" me) <> (f " ready (" ")" mr) <> (case mc of diff --git a/src/comp/GenABin.hs b/src/comp/GenABin.hs index c2c855fd5..1a075f2b2 100644 --- a/src/comp/GenABin.hs +++ b/src/comp/GenABin.hs @@ -34,7 +34,7 @@ import qualified Data.ByteString as B -- .ba file tag -- change this whenever the .ba format changes -- See also GenBin.header header :: [Byte] -header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260616-1" +header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260618-1" genABinFile :: ErrorHandle -> String -> ABin -> IO () genABinFile errh fn abin = diff --git a/src/comp/GenFuncWrap.hs b/src/comp/GenFuncWrap.hs index 4c8f73f1a..daa1f9879 100644 --- a/src/comp/GenFuncWrap.hs +++ b/src/comp/GenFuncWrap.hs @@ -9,13 +9,14 @@ import Error(internalError, ErrMsg(..), ErrorHandle, bsError) import Flags(Flags) import PPrint import Id -import PreIds(idFromWrapField, idActionValue, idStrArg) +import PreIds(idFromWrapNoInline, idActionValue) import CSyntax +import CSyntaxUtil(mkList, stringLiteralAt) import SymTab import Scheme import Assump import Type(tModule, fn) -import CType(getArrows, getRes, cTStr) +import CType(getArrows, getRes) import Pred(expandSyn) import TypeCheck(cCtxReduceDef) import Subst(tv) @@ -226,8 +227,13 @@ addFuncWrap errh symt is (CPackage modid exps imps impsigs fixs ds includes) = d let -- the number of arguments n = nArrows t_ -- definitions for the wrapper and wrappee - d <- funcDef errh symt i qt i_ n qt_ - let d_ = funcDef_ mi i i_ qt_ args + d <- funcDef errh symt i qt i_ n args qt_ + -- the "wrappee": a foreign declaration marked as a + -- noinline function (the final True = cforg_is_noinline); + -- its port names are filled in later, in IExpand, by the + -- primNoInline primitive (see fromWrapFieldNoInline) from + -- the types via the SplitPorts class + let d_ = Cforeign i_ qt_ (Just (getIdString mi)) Nothing True return [d, d_] _ -> internalError ("addFuncWrap: " ++ ppString (ti_, i_)) @@ -240,16 +246,24 @@ addFuncWrap errh symt is (CPackage modid exps imps impsigs fixs ds includes) = d -- oqt = qualified type of the original function -- i_ = the escaped id (declared as foreign) -- n = the number of arguments to the foreign function +-- args = the function's argument ids (for naming the input ports) -- t = the base type of the foreign function -funcDef :: ErrorHandle -> SymTab -> Id -> CQType -> Id -> Int -> CQType -> IO CDefn -funcDef errh symt i oqt@(CQType _ ot) i_ n (CQType _ t) = +funcDef :: ErrorHandle -> SymTab -> Id -> CQType -> Id -> Int -> [Id] -> CQType -> IO CDefn +funcDef errh symt i oqt@(CQType _ ot) i_ n args (CQType _ t) = let pos = getPosition i r = getRes ot -- the result is either an actionvalue or a value isAV = isActionValue symt r - fnp = mkTypeProxyExpr $ TAp (cTCon idStrArg) $ cTStr (getIdFString i) (getIdPosition i) - expr = cVApply idFromWrapField [fnp, CVar i_] + -- noinline functions do not support naming pragmas, so the function + -- name is used both as the port-name prefix and as the result port name + -- (matching what GenWrap uses for the generated module's interface + -- method), so that fromWrapNoInline computes the same (split) port names + -- that the module exposes. + name = stringLiteralAt pos (getIdString i) + arg_names = mkList pos [ stringLiteralAt (getPosition a) (getIdString a) + | a <- args ] + expr = cVApply idFromWrapNoInline [name, arg_names, CVar i_] in -- XXX this code works for Action/ActionValue foreign funcs, -- XXX but they are not handled by astate yet @@ -260,28 +274,6 @@ funcDef errh symt i oqt@(CQType _ ot) i_ n (CQType _ t) = -- --------------- --- make the foreign function declaration (with escaped id) to be wrapped. --- mi = the combinational module to instantiate --- i_ = the escaped identifier to use for the foreign declaration --- i = the original identifier, which also happens to be the --- name of the method on the module, which is the prefix for --- the port names for the method (used to generate the port names) --- qt_ = the qualified type of the wrapped function --- (this has been bitified by GenWrap) --- args = List of function args -funcDef_ :: Id -> Id -> Id -> CQType -> [Id] -> CDefn -funcDef_ mi i i_ qt_ args = - let - mstr = getIdString mi - -- input ports: _ - iports = [ oport ++ "_" ++ getIdString arg | arg <- args ] - -- output port: - oport = getIdString i - in - Cforeign i_ qt_ (Just mstr) (Just (iports, [oport])) True - --- --------------- - nArrows :: Type -> Int nArrows t = length $ fst $ getArrows t diff --git a/src/comp/GenWrap.hs b/src/comp/GenWrap.hs index 42bf42d73..fea5e3cf5 100644 --- a/src/comp/GenWrap.hs +++ b/src/comp/GenWrap.hs @@ -690,7 +690,7 @@ fixCModuleVerilog n (ss,ts,ps) output_type <- if isAV then getAVType "fixCModVer" rt else return rt let output_stmt = map ((flip mStmtSPT) rt) outs -- we let the type-checker error on mismatches - return (output_stmt ++ (zipWith mStmtSPT inps (arg_types finf))) + return (output_stmt ++ (zipWith mStmtSPT (concat inps) (arg_types finf))) saveFieldTypes finf (Inout { vf_inout = vn }) = do let rt = ret_type finf vp = (vn,[]) @@ -1642,7 +1642,7 @@ fixupVeriField pps vportprops m@(Method { }) = m { vf_inputs = inputs', vf_outputs = outputs', vf_enable = enable'' } - where inputs' = map fixup (vf_inputs m) + where inputs' = map (map fixup) (vf_inputs m) outputs' = map fixup (vf_outputs m) enable' = fmap fixup (vf_enable m) fixup = fixupPort vportprops diff --git a/src/comp/IConv.hs b/src/comp/IConv.hs index f17bbde73..95261d44e 100644 --- a/src/comp/IConv.hs +++ b/src/comp/IConv.hs @@ -81,19 +81,21 @@ iConvVar flags r env i = Just (VarInfo VarPrim (_ :>: sc) _ _) -> ICon i (ICPrim (iConvSc flags r sc) (toPrim i)) Just (VarInfo (VarForg name mps) (_ :>: sc) _ _) -> let t = iConvSc flags r sc + -- inputs are grouped per argument; + -- foreign functions have one (unsplit) port per argument, + -- so each inner list is a singleton. + -- A single-output foreign function may be polymorphic + -- (e.g. Fork's `Bit n -> Bit m`), whose port sizes are + -- type variables that addSizes cannot read; the sizes + -- are not used for a single output, so just record 0. ops' = case mps of - Just (ips, [op]) -> Just (zip ips (repeat 0), [(op, 0)]) -- XXX a hack for single output + Just (ips, [op]) -> Just (map (\ip -> [(ip, 0)]) ips, [(op, 0)]) Just (ips, ops) -> Just (addSizes ips ops [] t) Nothing -> Nothing addSizes (i:is) ops ins (ITAp (ITAp arr (ITAp bit (ITNum n))) r) | arr == itArrow && bit == itBit = - addSizes is ops ((i, n):ins) r - addSizes [] ops ins t = (reverse ins, zip ops (flatPairs t)) + addSizes is ops ([(i, n)]:ins) r + addSizes [] ops ins t = (reverse ins, zip ops (bitTupleSizes t)) addSizes is ops ins t = internalError ("addSizes mismatch: " ++ ppReadable (is, ops, ins, t)) - flatPairs (ITAp bit (ITNum n)) | bit == itBit = [n] - flatPairs (ITAp (ITAp pair a) b) = flatPairs a ++ flatPairs b - flatPairs it = internalError - ("IConv.iConvVar.flatPairs: " ++ - show it) in ICon i (ICForeign t name False ops' Nothing) Just (VarInfo VarMeth (_ :>: Forall _ ((pp:_) :=> _)) _ _) -> let (IsIn cl _) = removePredPositions pp diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 807e5e352..21069b438 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -1056,8 +1056,8 @@ iExpandField modId implicitCond clkRst (i, bi, e, t) = do -- expand a method iExpandMethod :: Id -> Integer -> [Id] -> HPred -> - (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [String], [String], HExpr) -> - G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), + (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [[String]], [String], HExpr) -> + G ([IMethodInput], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) iExpandMethod modId n args implicitCond clkRst@(curClk, _) (i, bi, ins, outs, e) = do when doDebug $ traceM ("iExpandMethod " ++ ppString i ++ " " ++ ppReadable e) @@ -1073,31 +1073,57 @@ iExpandMethod modId n args implicitCond clkRst@(curClk, _) (i, bi, ins, outs, e) _ -> iExpandMethod' implicitCond curClk (i, bi, outs, e') p iExpandMethodLam :: Id -> Integer -> [Id] -> HPred -> - (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [String], [String], HExpr) -> + (HClock, HReset) -> (Id, BetterInfo.BetterInfo, [[String]], [String], HExpr) -> Id -> IType -> Pred HeapData -> - G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), + G ([IMethodInput], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) iExpandMethodLam modId n args implicitCond clkRst (i, bi, ins, outs, eb) li ty p = do - --traceM ("iExpandMethodLam " ++ ppString i ++ " " ++ show (ins, outs)) if null ins then internalError "iExpandMethodLam: no inputs" else return () - 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 + let arg_port_types = itTupleElems ty + when (length arg_port_types /= length (head ins)) $ + internalError $ "iExpandMethodLam: port-count mismatch for method " ++ + ppString i ++ " arg type " ++ ppReadable ty ++ + " (" ++ show (length arg_port_types) ++ + " ports vs " ++ show (length (head ins)) ++ + " names): " ++ show (head ins) + let arg_ports :: [(Id, IType)] + arg_ports = zipWith (\name pt -> (mkId (getPosition i) (mkFString name), pt)) + (head ins) arg_port_types + arg_expr = buildArgExpr ty arg_ports + eb' = eSubst li arg_expr eb (its, (d, ws1, wf1), (wd, ws2, wf2)) <- - iExpandMethod modId (n+1) (i':args) (pConj implicitCond p) clkRst (i, bi, tail ins, outs, eb') - let inps :: [VPort] + iExpandMethod modId (n+1) (map fst arg_ports ++ args) + (pConj implicitCond p) clkRst (i, bi, tail ins, outs, eb') + let inps :: [[VPort]] inps = vf_inputs wf1 - let wf1' :: VFieldInfo + arg_vports = map (id_to_vPort . fst) arg_ports + wf1' :: VFieldInfo wf1' = case wf1 of - (Method {}) -> wf1 { vf_inputs = ((id_to_vPort i'):inps) } + (Method {}) -> wf1 { vf_inputs = arg_vports : inps } _ -> internalError "iExpandMethodLam: unexpected wf1" - return ((i', ty) : its, (d, ws1, wf1'), (wd, ws2, wf2)) + return (arg_ports : its, (d, ws1, wf1'), (wd, ws2, wf2)) + +-- Build an HExpr matching the given tuple type's shape, with one ICMethArg +-- per hardware input port (in the order given). +buildArgExpr :: IType -> [(Id, IType)] -> HExpr +buildArgExpr ty arg_ports + | ty == itPrimUnit = + ICon idPrimUnit (ICTuple { iConType = itPrimUnit, fieldIds = [] }) + | otherwise = case ty of + ITAp (ITAp (ITCon ip _ _) t1) t2 | ip == idPrimPair -> + let n1 = length (itTupleElems t1) + (l1, l2) = splitAt n1 arg_ports + e1 = buildArgExpr t1 l1 + e2 = buildArgExpr t2 l2 + in iMkPairAt noPosition t1 t2 e1 e2 + _ -> case arg_ports of + [(pid, _)] -> ICon pid (ICMethArg ty) + _ -> internalError $ "buildArgExpr: port count mismatch for " ++ + ppReadable ty iExpandMethod' :: HPred -> HClock -> (Id, BetterInfo.BetterInfo, [String], HExpr) -> Pred HeapData -> - G ([(Id, IType)], (HDef, HWireSet, VFieldInfo), + G ([IMethodInput], (HDef, HWireSet, VFieldInfo), (HDef, HWireSet, VFieldInfo)) iExpandMethod' implicitCond curClk (i, bi, outs, e0) p0 = do norm <- getTypeNormalizerC @@ -2179,6 +2205,24 @@ evalStringList e = do else internalError ("evalStringList con: " ++ show i) _ -> nfError "evalStringList" e' +-- Evaluate a `List (List String)` literal into `[[String]]`. +evalStringListList :: HExpr -> G ([[String]], Position) +evalStringListList e = do + e' <- evaleUH e + case e' of + IAps (ICon i _) _ [a] -> + if i == idCons noPosition then do + a' <- evaleUH a + case a' of + IAps (ICon _ (ICTuple {})) _ [e_h, e_t] -> do + (h, _) <- evalStringList e_h + (t, _) <- evalStringListList e_t + return (h:t, getIExprPosition e') + _ -> internalError ("evalStringListList Cons: " ++ showTypeless a') + else if i == idPrimChr then return ([], getIExprPosition e') + else internalError ("evalStringListList con: " ++ show i) + _ -> nfError "evalStringListList" e' + ----------------------------------------------------------------------------- evalHandle :: HExpr -> G Handle @@ -3170,7 +3214,7 @@ conAp' i (ICPrim _ PrimIsRawUndefined) _ (T t : E e : as) = do return (P p iFalse) conAp' i (ICPrim _ PrimMethod) _ [T t, E eInNames, E eOutNames, E meth] = do - (inNames, _) <- evalStringList eInNames + (inNames, _) <- evalStringListList eInNames (outNames, _) <- evalStringList eOutNames P p meth' <- eval1 meth return $ P p $ ICon (dummyId noPosition) $ ICMethod { @@ -3180,6 +3224,31 @@ conAp' i (ICPrim _ PrimMethod) _ [T t, E eInNames, E eOutNames, E meth] = do iMethod = meth' } +-- A {-# noinline #-} Bluespec function is compiled into a separate module and +-- referenced like a foreign function (GenFuncWrap emits a Cforeign for it). +-- primNoInline records the (possibly split) input/output port names of that +-- noinline function onto the reference, by rewriting foports. The per-port +-- sizes come from the (bitified) type; zero-width ports are dropped, to match +-- the names (which inputPortNames/outputPortNames have already filtered). +conAp' i (ICPrim _ PrimNoInline) _ [T _t, E eInNames, E eOutNames, E fe] = do + (inNames, _) <- evalStringListList eInNames + (outNames, _) <- evalStringList eOutNames + P p fe' <- eval1 fe + case fe' of + ICon fi fc@(ICForeign { iConType = ft }) -> + let (argTys, resTy) = itGetArrows ft + -- pair each (non-zero-width) port name with its size, flattening a + -- bitified tuple type into the bit-sizes of its ports + mkPorts names ty = zip names (filter (/= 0) (bitTupleSizes ty)) + -- inputs are grouped per argument (kept as a 2-d list) + ips = zipWith mkPorts inNames argTys + ops = mkPorts outNames resTy + in return $ P p $ ICon fi (fc { foports = Just (ips, ops) }) + -- the argument is the foreign-function reference GenFuncWrap produced for + -- the noinline function, so it is always an ICForeign here + _ -> internalError ("conAp' PrimNoInline: not a foreign-function reference: " ++ + ppReadable fe') + -- XXX is this still needed? conAp' i (ICUndet { iConType = t }) e as | t == itClock = errG (getIdPosition i, EUndeterminedClock) diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index 330b742ef..2319ae8e9 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -2075,7 +2075,7 @@ chkIfcPortNames errh args ifcs (ClockInfo ci co _ _) (ResetInfo ri ro) = ifc_port_names = [ (n, i) | IEFace {ief_fieldinfo = Method i _ _ _ ins outs en} <- ifcs, - (VName n, _) <- ins ++ outs ++ maybeToList en ] + (VName n, _) <- concat ins ++ outs ++ maybeToList en ] ifc_inout_names = [ (n, i) | IEFace {ief_fieldinfo = Inout i (VName n) _ _} <- ifcs ] ifc_clock_names = diff --git a/src/comp/ISyntax.hs b/src/comp/ISyntax.hs index dd0260966..7c59cf405 100644 --- a/src/comp/ISyntax.hs +++ b/src/comp/ISyntax.hs @@ -11,6 +11,7 @@ module ISyntax( IRules(..), IRule(..), IEFace(..), + IMethodInput, IModule(..), IAbstractInput(..), IStateVar(..), @@ -186,14 +187,19 @@ data IAbstractInput = -- IAI_Struct [(Id, IType)] deriving (Eq, Show, Generic.Data, Generic.Typeable) +-- One method argument, decomposed into the ports it occupies (one port for an +-- unsplit argument, several for a split struct/tuple). A method's arguments +-- are a list of these groups. +type IMethodInput = [(Id, IType)] + data IEFace a = IEFace { -- This is either an actual method or a ready signal for another -- method. Use 'isRdyId' to determine which. Use 'mkRdyId' on -- the name of an actual method to construct the name of its -- associated ready method. ief_name :: Id, - -- arguments - ief_args :: [(Id, IType)], + -- arguments, split into ports. + ief_args :: [IMethodInput], -- Prior to 'iSplitIface', 'ief_value' contains the expression for -- the whole method and 'ief_body' is empty. After 'iSplitIface', -- 'ief_value' contains the return value (if any) and 'ief_body' @@ -745,6 +751,10 @@ data IConInfo a = | ICPrim { iConType :: IType, primOp :: PrimOp } -- primitive -- foreign function; foports specifies input and output port names in verilog -- (for functions implemented via module instantiation - primarily "noinlined") + -- The inputs are grouped per argument (the inner list is the ports of + -- one argument, of which there may be several when the argument splits); + -- the outputs are a flat list (the single result, possibly split). + -- Each port is its name and bit size. -- Nothing in foports indicates this is a "true" foreign function -- (positional module instantiation is no longer supported) -- fcallNo is a cookie used to mark foreign function calls during elaboration @@ -753,7 +763,7 @@ data IConInfo a = | ICForeign { iConType :: IType, fName :: String, isC :: Bool, - foports :: Maybe ([(String, Integer)], [(String, Integer)]), + foports :: Maybe ([[(String, Integer)]], [(String, Integer)]), fcallNo :: Maybe Integer } -- constructor | ICCon { iConType :: IType, conTagInfo :: ConTagInfo } @@ -820,7 +830,11 @@ data IConInfo a = -- only exists before expansion | ICSchedPragmas { iConType :: IType, iPragmas :: [CSchedulePragma] } - | ICMethod { iConType :: IType, iInputNames :: [String], iOutputNames :: [String], iMethod :: IExpr a } + | ICMethod { iConType :: IType, + -- per-source-argument input port name groups + iInputNames :: [[String]], + iOutputNames :: [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 } @@ -1062,7 +1076,7 @@ ppMV d (i, ty) = ppId d i <+> text "::" <+> pPrint d 0 ty instance PPrint (IEFace a) where pPrint d p (IEFace i vs et rules wp fi) = text "-- args" $+$ - foldr (($+$) . ppMV d) b vs + foldr (($+$) . ppMV d) b (concat vs) where b = text "-- body" $+$ (case et of Just (e,t) -> ppDef d $ IDef i t e [] diff --git a/src/comp/ISyntaxUtil.hs b/src/comp/ISyntaxUtil.hs index bbe73dd93..92c8614de 100644 --- a/src/comp/ISyntaxUtil.hs +++ b/src/comp/ISyntaxUtil.hs @@ -939,6 +939,25 @@ itGetArrows it = itGetArrows' [] it where itGetArrows' ts (ITAp (ITAp arr a) r) | arr == itArrow = itGetArrows' (a:ts) r itGetArrows' ts r = (reverse ts, r) +-- Flatten a (possibly nested) right-associated PrimPair tuple type into its +-- element types in left-to-right order. PrimUnit contributes no elements, +-- PrimPair recurses into both sides, anything else is a single element. +itTupleElems :: IType -> [IType] +itTupleElems t + | t == itPrimUnit = [] + | otherwise = case t of + ITAp (ITAp (ITCon ip _ _) t1) t2 | ip == idPrimPair -> + itTupleElems t1 ++ itTupleElems t2 + _ -> [t] + +-- The element bit-widths of a (bitified) tuple type, in left-to-right port order +-- (flattening nested PrimPair tuples via itTupleElems). A non-Bit leaf yields +-- 0, so callers that want only the actual ports can filter out the zeros. +bitTupleSizes :: IType -> [Integer] +bitTupleSizes = map leafSize . itTupleElems + where leafSize (ITAp b (ITNum n)) | b == itBit = n + leafSize _ = 0 + -- ############################################################################# -- # -- ############################################################################# diff --git a/src/comp/LambdaCalc.hs b/src/comp/LambdaCalc.hs index bc55c1db7..a645b6163 100644 --- a/src/comp/LambdaCalc.hs +++ b/src/comp/LambdaCalc.hs @@ -27,6 +27,7 @@ import IntLit import Prim(PrimOp(..)) import VModInfo(vName, VArgInfo(..), isParam, isPort, getVNameString) import ASyntax +import ASyntaxUtil(argInputPorts) import LambdaCalcUtil -- TODO: @@ -56,13 +57,14 @@ convAPackageToLambdaCalc errh flags apkg0 | (apkg_is_wrapped apkg0) = -- there should be one value method, and its constant RDY fn_defs = case ifcs of - [AIDef methId args _ p (ADef _ ret_t ret_e _) _ _, + [iface@(AIDef methId _ _ p (ADef _ ret_t ret_e _) _ _), AIDef rdyId _ _ _ (ADef _ _ rdy_e _) _ _] | (isRdyId rdyId) && (isTrue rdy_e) -> -- this is very similar to convAIFace for AIDef, -- except that the function doesn't take a state argument -- and has a different name let + args = aIfaceArgs iface rt = convAType ret_t argset = S.fromList (map fst args) @@ -747,8 +749,9 @@ convAIFace :: DefMap -> InstMap -> MethodOrderMap -> Id -> AIFace -> [SDefn] convAIFace defmap instmap mmap modId - (AIDef mId args _ p (ADef _ ret_t ret_e _) _ _) = + iface@(AIDef mId _ _ p (ADef _ ret_t ret_e _) _ _) = let + args = aIfaceArgs iface mod_ty = modType modId [] rt = convAType ret_t @@ -770,8 +773,9 @@ convAIFace defmap instmap mmap modId body] convAIFace defmap instmap mmap modId - (AIAction args _ p mId rs _) = + iface@(AIAction _ _ p mId rs _) = let + args = aIfaceArgs iface mod_ty = modType modId [] -- arguments are Bit type @@ -788,8 +792,9 @@ convAIFace defmap instmap mmap modId body] convAIFace defmap instmap mmap modId - (AIActionValue args _ p mId rs (ADef _ def_t def_e _) _) = + iface@(AIActionValue _ _ p mId rs (ADef _ def_t def_e _) _) = let + args = aIfaceArgs iface mod_ty = modType modId [] -- return value is Bit type ret_ty = convAType def_t @@ -1005,7 +1010,8 @@ convStmt modId avmap (AStmtAction cset (ACall obj meth as)) = do -- convert the condition c_expr <- convAExpr c -- convert the arguments - a_exprs <- mapM convAExpr as + -- a SplitPorts argument expands into one AExpr per hardware port + a_exprs <- mapM convAExpr (concatMap argInputPorts as) let -- the kind of module that this instance is @@ -1185,7 +1191,7 @@ convAExpr (AMethCall _ obj meth as) = do let (mod, _, _) = lookupMod instmap obj mname = methId mod meth modState = SSelect state_expr (instFieldId modId obj) - a_exprs <- mapM convAExpr as + a_exprs <- mapM convAExpr (concatMap argInputPorts as) return $ SApply (SVar mname) (a_exprs ++ [modState]) convAExpr e@(AMethValue t obj meth) = diff --git a/src/comp/LambdaCalcUtil.hs b/src/comp/LambdaCalcUtil.hs index 01876d349..08422c36f 100644 --- a/src/comp/LambdaCalcUtil.hs +++ b/src/comp/LambdaCalcUtil.hs @@ -217,6 +217,8 @@ getAExprDefs def_map known ((ANoInlineFunCall _ _ _ args):es) = getAExprDefs def_map known (args ++ es) getAExprDefs def_map known ((AFunCall _ _ _ _ args):es) = getAExprDefs def_map known (args ++ es) +getAExprDefs def_map known ((ATuple _ elems):es) = + getAExprDefs def_map known (elems ++ es) getAExprDefs def_map known ((ASDef _ i):es) = case (M.lookup i known) of Just _ -> getAExprDefs def_map known es diff --git a/src/comp/Parser/BSV/CVParser.lhs b/src/comp/Parser/BSV/CVParser.lhs index 311fa20f3..3f2a3dbd7 100644 --- a/src/comp/Parser/BSV/CVParser.lhs +++ b/src/comp/Parser/BSV/CVParser.lhs @@ -1462,7 +1462,8 @@ returns a single identifier formed by joining the components with underscores. > -- Bool indicates whether there's a separate Ready method for this one > pMethodVeriProt prefix = > do pos <- getPos -> -- TODO: Add syntax for specifiying multiple output ports +> -- A hand-written BVI value method has a single result port; there is +> -- no syntax for multiple output ports yet (TODO). > (optOPort, name) <- pMethodNameOptOPort "method output port or name" > let oPorts = maybeToList optOPort > multi <- option 1 (pInBrackets pDecimal) @@ -1512,12 +1513,15 @@ returns a single identifier formed by joining the components with underscores. > clk rst 0 [] [p] Nothing, > False)] > Just _ -> internalError "pMethodVeriProt(4)" +> -- BVI does not support method args with multiple ports, +> -- but VModInfo.Method expects a list of ports for each arg. +> let argGroups = map (:[]) args > return ((name, > V.Method fullname > clk > rst > multi -> args +> argGroups > oPorts > en, > not(null nullOrReady)) @@ -4602,7 +4606,8 @@ a "module verilog": > let g (s,Nothing) = [(s,[])] > g (s,Just g) = [(s,[]),(g,[])] > f (Nothing, _) = [] -> f (Just i , cmg) = [V.Method i Nothing Nothing 1 (concat(map g cmg)) [] Nothing] +> f (Just i , cmg) = +> [V.Method i Nothing Nothing 1 (map (:[]) (concat (map g cmg))) [] Nothing] > in concat . (map f) > pImperativeForeignModuleAt :: Position -> Attributes -> ImperativeFlags diff --git a/src/comp/Parser/BSV/CVParserImperative.lhs b/src/comp/Parser/BSV/CVParserImperative.lhs index 11b4682af..473faef2e 100644 --- a/src/comp/Parser/BSV/CVParserImperative.lhs +++ b/src/comp/Parser/BSV/CVParserImperative.lhs @@ -1481,7 +1481,7 @@ some of these restrictions could be lifted if we made the compiler more clever > _ -> ioerrs1 > ioerrs3 = foldr (\port iers -> addInput pos (fst port) iers) > ioerrs2 -> (vf_inputs inf) +> (vfMethodArgPorts inf) > chkBVIPorts (ISBVI pos (BVI_interface (_,_,stmts))) ioerrs = ioerrs' > where ioerrs' = foldr chkBVIPorts ioerrs stmts > chkBVIPorts _ ioerrs = ioerrs diff --git a/src/comp/Parser/Classic/CParser.hs b/src/comp/Parser/Classic/CParser.hs index fd7b585ac..52a9ed7f6 100644 --- a/src/comp/Parser/Classic/CParser.hs +++ b/src/comp/Parser/Classic/CParser.hs @@ -148,7 +148,8 @@ pModule = l L_module `into` \ pos -> ||! literal (mkFString "const") .> VPconst ||! literal (mkFString "unused") .> VPunused ||! literal (mkFString "inhigh") .> VPinhigh - mkMethod i n vps mo me = Method i Nothing Nothing n vps [] Nothing + -- each Verilog port corresponds to a single argument. + mkMethod i n vps mo me = Method i Nothing Nothing n (map (:[]) vps) [] Nothing pMStmt :: CParser CMStmt pMStmt = pModuleInterface diff --git a/src/comp/PreIds.hs b/src/comp/PreIds.hs index e13ca36d6..1981f275a 100644 --- a/src/comp/PreIds.hs +++ b/src/comp/PreIds.hs @@ -241,6 +241,9 @@ idFromWrapField = prelude_id_no fsFromWrapField idToWrapField = prelude_id_no fsToWrapField idSaveFieldPortTypes = prelude_id_no fsSaveFieldPortTypes +idFromWrapNoInline :: Id +idFromWrapNoInline = prelude_id_no fsFromWrapNoInline + -- 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 e7a246220..a9bc42357 100644 --- a/src/comp/PreStrings.hs +++ b/src/comp/PreStrings.hs @@ -206,8 +206,7 @@ fsMuxVal = mkFString "VAL" fsEnable = mkFString "EN_" fs_rdy = mkFString "RDY_" fs_rl = mkFString "RL_" -fs_arg = mkFString "ARG_" -fs_res = mkFString "RES_" +fs_port = mkFString "PORT_" fs_unnamed = mkFString "unnamed" s_unnamed = "unnamed" fs_T = mkFString "_T" @@ -349,6 +348,7 @@ fsMetaField = mkFString "MetaField" fsPolyWrapField = mkFString "val" fsWrapField = mkFString "WrapField" fsFromWrapField = mkFString "fromWrapField" +fsFromWrapNoInline = mkFString "fromWrapNoInline" fsToWrapField = mkFString "toWrapField" fsSaveFieldPortTypes = mkFString "saveFieldPortTypes" diff --git a/src/comp/Prim.hs b/src/comp/Prim.hs index e52c6fa97..45b167972 100644 --- a/src/comp/Prim.hs +++ b/src/comp/Prim.hs @@ -65,6 +65,7 @@ data PrimOp = | PrimInoutUncast | PrimMethod + | PrimNoInline | PrimIf | PrimMux @@ -359,6 +360,7 @@ toPrim i = tp (getIdBaseString i) -- XXXXX tp "primInoutCast" = PrimInoutCast tp "primInoutUncast" = PrimInoutUncast tp "primMethod" = PrimMethod + tp "primNoInline" = PrimNoInline tp "primIntegerToBit" = PrimIntegerToBit tp "primIntegerToUIntBits" = PrimIntegerToUIntBits tp "primIntegerToIntBits" = PrimIntegerToIntBits @@ -679,6 +681,7 @@ instance NFData PrimOp where rnf PrimInoutCast = () rnf PrimInoutUncast = () rnf PrimMethod = () + rnf PrimNoInline = () rnf PrimIf = () rnf PrimMux = () rnf PrimPriMux = () diff --git a/src/comp/SAL.hs b/src/comp/SAL.hs index ad58492ac..9b40d2839 100644 --- a/src/comp/SAL.hs +++ b/src/comp/SAL.hs @@ -59,13 +59,14 @@ convAPackageToSAL errh flags apkg0 | (apkg_is_wrapped apkg0) = -- there should be one value method, and its constant RDY fn_defs = case ifcs of - [AIDef methId args _ p (ADef _ ret_t ret_e _) _ _, + [iface@(AIDef methId _ _ p (ADef _ ret_t ret_e _) _ _), AIDef rdyId _ _ _ (ADef _ _ rdy_e _) _ _] | (isRdyId rdyId) && (isTrue rdy_e) -> -- this is very similar to convAIFace for AIDef, -- except that the function doesn't take a state argument -- and has a different name let + args = aIfaceArgs iface rt = convAType ret_t argset = S.fromList (map fst args) @@ -894,8 +895,9 @@ convAIFace :: DefMap -> InstMap -> MethodOrderMap -> AIFace -> [SDefn] -- TODO: support multiple method output ports convAIFace defmap instmap mmap - (AIDef methId args _ p (ADef _ ret_t ret_e _) _ _) = + iface@(AIDef methId _ _ p (ADef _ ret_t ret_e _) _ _) = let + args = aIfaceArgs iface rt = convAType ret_t argset = S.fromList (map fst args) @@ -915,8 +917,9 @@ convAIFace defmap instmap mmap body] convAIFace defmap instmap mmap - (AIAction args _ p methId rs _) = + iface@(AIAction _ _ p methId rs _) = let + args = aIfaceArgs iface -- arguments are Bit type argset = S.fromList (map fst args) arg_infos = map (\(i,t) -> (methArgId i, convAType t)) args @@ -931,8 +934,9 @@ convAIFace defmap instmap mmap -- TODO: support multiple method output ports convAIFace defmap instmap mmap - (AIActionValue args _ p methId rs (ADef _ def_t def_e _) _) = + iface@(AIActionValue _ _ p methId rs (ADef _ def_t def_e _) _) = let + args = aIfaceArgs iface -- return value is Bit type ret_ty = convAType def_t @@ -1138,7 +1142,8 @@ convStmt avmap (AStmtAction cset (ACall obj meth as)) = do -- convert the condition c_expr <- convAExpr c -- convert the arguments - a_exprs <- mapM convAExpr as + -- a SplitPorts argument expands into one AExpr per hardware port + a_exprs <- mapM convAExpr (concatMap argInputPorts as) let -- the kind of module that this instance is @@ -1293,7 +1298,7 @@ convAExpr (AMethCall _ obj meth as) = do let (submod, submod_tys, _) = lookupMod instmap obj fnvar = submodMethVar submod submod_tys meth modState = SStructSel state_expr (instFieldId obj) - a_exprs <- mapM convAExpr as + a_exprs <- mapM convAExpr (concatMap argInputPorts as) return $ sApply fnvar (a_exprs ++ [modState]) convAExpr e@(AMethValue t obj meth) = diff --git a/src/comp/SignalNaming.hs b/src/comp/SignalNaming.hs index 3d93e326c..bc3efaae0 100644 --- a/src/comp/SignalNaming.hs +++ b/src/comp/SignalNaming.hs @@ -65,7 +65,9 @@ signalNameFromAExpr' (expr@AMethCall { }) signalNameFromAExpr' (expr@AMethCall { }) = ppString (ae_objid expr) ++ "_" ++ ppString (unQualId (ameth_id expr)) ++ "_" ++ - connectWith "_" (map signalNameFromAExpr' (ae_args expr)) + connectWith "_" (map signalNameFromAExpr' (concatMap argPorts (ae_args expr))) + where argPorts (ATuple _ es) = es + argPorts e = [e] signalNameFromAExpr' (expr@AMethValue { }) = ppString (ae_objid expr) ++ "_" ++ ppString (unQualId (ameth_id expr)) signalNameFromAExpr' (expr@ATuple { }) = diff --git a/src/comp/SimCCBlock.hs b/src/comp/SimCCBlock.hs index 9619232e8..d95f5fe37 100644 --- a/src/comp/SimCCBlock.hs +++ b/src/comp/SimCCBlock.hs @@ -66,7 +66,7 @@ import Eval import ErrorUtil(internalError) import Data.Maybe -import Data.List(partition, intersperse, intercalate, nub, sortBy, genericDrop) +import Data.List(partition, intersperse, intercalate, nub, sortBy) import Data.List.Split(wordsBy) import Numeric(showHex) import Control.Monad(when) @@ -1069,7 +1069,7 @@ aExprToCExpr _ p@(APrim _ _ PrimStringConcat args) = argCount (==2) args $ aExprToCExpr _ p@(APrim _ _ _ _) = internalError ("unhandled primitive: " ++ (show p)) aExprToCExpr _ (AMethCall _ id mid args) = - do arg_list <- mapM (aExprToCExpr noRet) args + do arg_list <- mapM (aExprToCExpr noRet) (concatMap argInputPorts args) return $ (aInstMethIdToC id mid) `cCall` arg_list -- a tuple is laid out in wide data as a concatenation of its elements, -- with the first element in the most-significant bits (Verilog {e1,...,en}) @@ -1079,8 +1079,8 @@ aExprToCExpr ret e@(ATuple _ exprs) = -- elements strictly below the selected one; sizeAfter is therefore the low bit -- of element idx, and [aSize t + sizeAfter - 1 : sizeAfter] is its bit range. aExprToCExpr ret (ATupleSel t e idx) = - wideExtractPrim ret (aSize t) e (aSize t + sizeAfter - 1) sizeAfter - where sizeAfter = sum $ map aSize $ genericDrop idx $ att_elem_types $ ae_type e + wideExtractPrim ret (aSize t) e hi lo + where (hi, lo) = tupleElemRange (ae_type e) idx aExprToCExpr _ e@(AMGate _ id clkid) = do gmap <- gets gate_map case (M.lookup e gmap) of @@ -1283,12 +1283,9 @@ simFnStmtToCStmt (SFSOutputReset rstId expr) = -- for embedding in a larger CC statement aActionToCFunCall :: (Maybe (Bool,AId)) -> AAction -> State ConvState (ReturnStyle, CCExpr, CCExpr) -aActionToCFunCall _ c@(ACall id mth_id aargs) = - do cargs <- mapM (aExprToCExpr noRet) aargs - let (cond, arg_list) = - case cargs of - (x:xs) -> (x, xs) - _ -> internalError ("aActionToCFunCall: missing cond in ACall args") +aActionToCFunCall _ c@(ACall id mth_id (cond_e:srcArgs)) = + do cond <- aExprToCExpr noRet cond_e + arg_list <- mapM (aExprToCExpr noRet) (concatMap argInputPorts srcArgs) let call = (aInstMethIdToC id mth_id) `cCall` arg_list return (Direct, cond, call) aActionToCFunCall Nothing act@(AFCall {}) = diff --git a/src/comp/SimExpand.hs b/src/comp/SimExpand.hs index 501fc3c25..61de11f76 100644 --- a/src/comp/SimExpand.hs +++ b/src/comp/SimExpand.hs @@ -2248,20 +2248,13 @@ makeMethodTemps apkg = getNoInlineInfo :: [ADef] -> ( [ADef], [(String, String)] ) getNoInlineInfo defs = let - -- extract the output port name - getOutPortName (_,[(oname,_)]) = oname - getOutPortName _ = internalError "getNoInlineInfo: invalid ports" - cvtDef (ADef di dt (ANoInlineFunCall ft fi - (ANoInlineFun mod_name _ ports (Just inst_name)) + (ANoInlineFun mod_name _ _ (Just inst_name)) es) props) = let pos = getPosition fi - -- XXX because noinline "foreign" Id is escaped with an "_", - -- XXX we can't get the method name from "fi" - --methId = fi - methId = mkId pos (mkFString (getOutPortName ports)) + methId = mkId pos (mkFString (getIdBaseString fi)) instId = mkId pos (mkFString inst_name) new_def = ADef di dt (AMethCall ft instId methId es) props in diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index 153873dbb..c6a8cd2ff 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -1210,7 +1210,7 @@ mkActionMethodExecStmts top_ifc top_vmeth_set top_ameth_set inst_map full_dmap method = headOrErr ("method not in interface: " ++ (ppReadable mid)) [ m | m <- top_ifc, aif_name m == mid ] args = [ ASPort t (i `inlineIdFrom` top_blk_name) - | (i,t) <- aif_inputs method ] + | (i,t) <- aIfaceArgs method ] cond_stmt = SFSCond (ASDef (ATBit 1) wf) [SFSMethodCall blk_id mid args] [] diff --git a/src/comp/SimPackage.hs b/src/comp/SimPackage.hs index e8626a520..a7f374f5b 100644 --- a/src/comp/SimPackage.hs +++ b/src/comp/SimPackage.hs @@ -382,7 +382,7 @@ getPortInfo pps aif = when (isEnWhenRdy pps name) (fail "no enable port") return (fst e) args = aIfaceArgs aif - ps = map fst (vf_inputs vfi) + ps = map fst (vfMethodArgPorts vfi) ins = [ (t,i,vn) | ((i,t),vn) <- zip args ps ] rt = aIfaceResType aif -- A value method has at most one result. In Bluesim that whole value diff --git a/src/comp/TCheck.hs b/src/comp/TCheck.hs index 20c627f23..f51434c84 100644 --- a/src/comp/TCheck.hs +++ b/src/comp/TCheck.hs @@ -682,19 +682,35 @@ tiExpr as td exp@(CmoduleVerilog name ui clks rsts args fields sch ps) = do s <- getSubst let mtype = expandSyn (apSub s t) let (argTypes, resType) = getArrows mtype - - -- This function checks that the number of port names - -- matches the number of arguments in the type. - let chkArgs :: [VPort] -> [Type] -> TI () - chkArgs ports types = - if (length ports > length types) - then -- The extra port names could be used in the error - err (getPosition f, - EForeignModTooManyPorts f_str) - else if (length ports < length types) - then err (getPosition f, - EForeignModTooFewPorts f_str) - else mapM_ chkArgType types + -- Decompose one source-language argument's type into its + -- input port types (PrimUnit contributes no ports, + -- PrimPair recurses, any other type is a single port). + argPortTypes :: Type -> [Type] + argPortTypes (TAp (TAp (TCon (TyCon pi _ _)) l) r) + | pi == idPrimPair = argPortTypes l ++ argPortTypes r + argPortTypes ty + | ty == tPrimUnit = [] + | otherwise = [ty] + + -- Regroup the flat BVI port list per source-language argument, + -- consuming exactly the input-port count for each argument's + -- type. The lists must finish together. + let chkArgs :: [VPort] -> [Type] -> TI [[VPort]] + chkArgs ports srcArgs = go ports srcArgs + where + go [] [] = return [] + go _ [] = err (getPosition f, + EForeignModTooManyPorts f_str) + go ps (srcTy:srcTys) = + let leaves = argPortTypes srcTy + n = length leaves + in if length ps < n + then err (getPosition f, + EForeignModTooFewPorts f_str) + else do mapM_ chkArgType leaves + let (here, rest) = splitAt n ps + groups <- go rest srcTys + return (here : groups) -- This function checks that the argument types are bitable chkArgType t = @@ -809,15 +825,17 @@ tiExpr as td exp@(CmoduleVerilog name ui clks rsts args fields sch ps) = do else errInoutHasArgs Method { vf_inputs = inputs, vf_enable = me, vf_outputs = outputs } -> do -- updates inputs, me and mo when processing Classic format - (inputs', me', outputs') <- chkResType inputs me outputs resType + -- chkResType still works on a flat port list + (inputs', me', outputs') <- chkResType (concat inputs) me outputs resType -- check if any actions are SB with themselves when (((isActionWithValue resType) || (isActionWithoutValue resType) || (isPrimAction resType)) && (f `elem` self_sbs)) (errActionSelfSB f) - chkArgs inputs' argTypes - return (vfi { vf_inputs = inputs', vf_enable = me', vf_outputs = outputs' }) + -- Regroup the flat port list per source-arg + groupedInputs <- chkArgs inputs' argTypes + return (vfi { vf_inputs = groupedInputs, vf_enable = me', vf_outputs = outputs' }) -- paramResults <- mapM tiParam es qsses <- mapM tiArg args -- let (pses, tys) = unzip paramResults diff --git a/src/comp/VIOProps.hs b/src/comp/VIOProps.hs index 8180646c3..f59648288 100644 --- a/src/comp/VIOProps.hs +++ b/src/comp/VIOProps.hs @@ -154,8 +154,8 @@ getIOProps flags ppp@(ASPackage _ _ _ os is ios vs _ ds io_ds fs _ _ _) = -- for each method (not clocks or resets) vfi@(Method {}) <- vFields (avi_vmi v), -- for each method output port - (methOutPart, (vname, pprops)) - <- zip (map MethodResult (methResultNums (vf_outputs vfi))) + (methpart, (vname, pprops)) + <- zip (map MethodResult (splitPortNums (vf_outputs vfi))) (vf_outputs vfi), -- for each port copy @@ -166,7 +166,7 @@ getIOProps flags ppp@(ASPackage _ _ _ os is ios vs _ ds io_ds fs _ _ _) = let meth_id = mkMethId (avi_vname v) (vf_name vfi) ino - methOutPart, + methpart, -- convert to Verilog signal name let veri_id = xLateIdUsingFStringMap nmap meth_id ] @@ -243,9 +243,13 @@ getIOProps flags ppp@(ASPackage _ _ _ os is ios vs _ ds io_ds fs _ _ _) = createVerilogNameMapForAVInst flags v, -- for each method (not clocks or resets) vfi@(Method {}) <- vFields (avi_vmi v), - -- for each method input part (args and enables) + -- for each method input part (args and enables); + -- args carry (source-arg #, port-within-arg #) (methpart, (vname, pprops)) - <- (zip (map MethodArg [1..]) (vf_inputs vfi)) ++ + <- [ (MethodArg argN portM, port) + | (argN, ports) <- zip [1..] (vf_inputs vfi) + , (portM, port) <- zip (splitPortNums ports) ports + ] ++ case (vf_enable vfi) of Nothing -> [] Just port -> [(MethodEnable, port)], diff --git a/src/comp/VModInfo.hs b/src/comp/VModInfo.hs index ab96eb1b9..b24658954 100644 --- a/src/comp/VModInfo.hs +++ b/src/comp/VModInfo.hs @@ -5,7 +5,7 @@ module VModInfo(VModInfo, mkVModInfo, VName(..), VPort, VSchedInfo, VMethodConflictInfo, VPathInfo(..), VeriPortProp(..), VArgInfo(..), isParam, isPort, isClock, isReset, isInout, - VFieldInfo(..), + VFieldInfo(..), vfMethodArgPorts, VClockInfo(..), InputClockInf, OutputClockInf, VOscPort, VInputGatePort, VOutputGatePort, VResetInfo(..), ResetInf, VWireInfo(..), @@ -273,7 +273,8 @@ data VFieldInfo = Method { vf_name :: Id, -- method name vf_reset :: (Maybe Id), -- optional reset -- optional because the method may be independent of a reset signal vf_mult :: Integer, -- multiplicity - vf_inputs :: [VPort], + -- input ports grouped by method argument + vf_inputs :: [[VPort]], vf_outputs:: [VPort], vf_enable :: Maybe VPort } | Clock { vf_name :: Id } -- output clock name @@ -292,6 +293,12 @@ instance HasPosition VFieldInfo where getPosition (Reset i) = getPosition i -- or noPosition? getPosition (Inout { vf_name = n }) = getPosition n +-- Flat list of every hardware port across a method's source-level arguments. +-- For consumers that don't care about the per-argument grouping. +vfMethodArgPorts :: VFieldInfo -> [VPort] +vfMethodArgPorts (Method { vf_inputs = iss }) = concat iss +vfMethodArgPorts _ = [] + instance NFData VFieldInfo where rnf (Method x1 x2 x3 x4 x5 x6 x7) = rnf7 x1 x2 x3 x4 x5 x6 x7 rnf (Clock x) = rnf x @@ -301,7 +308,7 @@ instance NFData VFieldInfo where instance PPrint VFieldInfo where pPrint d p (Method n c r m i o e) = text "method " <> pouts o <> pPrint d p n <> pmult m <> - pins i <> pena e <+> ppMClk d c <+> ppMRst d r <> + pins (concat i) <> pena e <+> ppMClk d c <+> ppMRst d r <> text ";" where pouts [] = empty pouts [po] = pPrint d p po diff --git a/src/comp/bluetcl.hs b/src/comp/bluetcl.hs index 93f745e55..cfaebd412 100644 --- a/src/comp/bluetcl.hs +++ b/src/comp/bluetcl.hs @@ -3300,24 +3300,24 @@ rawIfcFieldName (RawInout i _ _ _ _) = i rawIfcFieldFromAIFace :: [PProp] -> AIFace -> RawIfcField rawIfcFieldFromAIFace _ - (AIDef i args _ _ def - (Method _ clk rst mult ins outs Nothing) _) = + iface@(AIDef i _ _ _ def + (Method _ clk rst mult ins outs Nothing) _) = let -- include the type in the "outs" outs' = zip outs $ case adef_type def of ATTuple ts -> ts t -> [t] - in RawMethod i mult clk rst (mapFst Just args) ins outs' Nothing + in RawMethod i mult clk rst (mapFst Just (aIfaceArgs iface)) (concat ins) outs' Nothing rawIfcFieldFromAIFace pps - (AIAction args _ _ i _ - (Method _ clk rst mult ins [] me@(Just _))) = + iface@(AIAction _ _ _ i _ + (Method _ clk rst mult ins [] me@(Just _))) = let -- filter out inhigh enable ports -- XXX is there a better way to do this? me' = if (isAlwaysEn pps i) then Nothing else me - in RawMethod i mult clk rst (mapFst Just args) ins [] me' + in RawMethod i mult clk rst (mapFst Just (aIfaceArgs iface)) (concat ins) [] me' rawIfcFieldFromAIFace pps - (AIActionValue args _ _ i _ def - (Method _ clk rst mult ins outs me@(Just _))) = + iface@(AIActionValue _ _ _ i _ def + (Method _ clk rst mult ins outs me@(Just _))) = let -- filter out inhigh enable ports -- XXX is there a better way to do this? me' = if (isAlwaysEn pps i) then Nothing else me @@ -3326,7 +3326,7 @@ rawIfcFieldFromAIFace pps case adef_type def of ATTuple ts -> ts t -> [t] - in RawMethod i mult clk rst (mapFst Just args) ins outs' me' + in RawMethod i mult clk rst (mapFst Just (aIfaceArgs iface)) (concat ins) outs' me' rawIfcFieldFromAIFace _ (AIClock i _ (Clock _)) = RawClock i rawIfcFieldFromAIFace _ (AIReset i _ (Reset _)) = RawReset i rawIfcFieldFromAIFace _ (AIInout i (AInout e) (Inout _ vn mclk mrst)) = @@ -3335,14 +3335,15 @@ rawIfcFieldFromAIFace _ aif = internalError ("rawIfcFieldFromAIFace: unexpected AIFace combo: " ++ ppReadable aif) -rawIfcFieldFromAVInst :: ([AType], Maybe AType, [AType]) -> +rawIfcFieldFromAVInst :: ([[AType]], Maybe AType, [AType]) -> VFieldInfo -> RawIfcField rawIfcFieldFromAVInst (arg_tys,_,out_tys) (Method i clk rst mult ins outs me) = let -- XXX AVInst doesn't record argument names - args = zip (repeat Nothing) arg_tys + -- flatten per-arg port type groups for the RawMethod args field + args = zip (repeat Nothing) (concat arg_tys) -- add the return bit-type to the outs outs' = zip outs out_tys - in RawMethod i mult clk rst args ins outs' me + in RawMethod i mult clk rst args (concat ins) outs' me rawIfcFieldFromAVInst _ (Clock i) = RawClock i rawIfcFieldFromAVInst _ (Reset i) = RawReset i rawIfcFieldFromAVInst (_,_,[t]) (Inout i vn mclk mrst) = RawInout i t vn mclk mrst @@ -3645,8 +3646,8 @@ getSubmodPortInfo mtifc avi = do concatMap getIfcHier ifc_hier) adjustPrimFields :: Maybe Type -> AVInst -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustPrimFields Nothing _ vfts = vfts adjustPrimFields (Just tifc) avi vfts = if (leftCon tifc == Just idReg) @@ -3690,8 +3691,8 @@ adjustPrimFields (Just tifc) avi vfts = else vfts -- This is a no-op but it does add some error checking -adjustRegAlignedFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustRegAlignedFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustRegAlignedFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) | (i `qualEq` id_read noPosition) = vf @@ -3701,8 +3702,8 @@ adjustRegAlignedFields (vfi, fts) = in (map renameField vfi, fts) -adjustRegFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustRegFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustRegFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) | (i `qualEq` idPreludeRead) = vf { vf_name = id_read noPosition } @@ -3711,8 +3712,8 @@ adjustRegFields (vfi, fts) = ppReadable (vf_name vf)) in (map renameField vfi, fts) -adjustFIFOFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustFIFOFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustFIFOFields (vfi, fts) = let enq_rdy = mkRdyId idEnq deq_rdy = mkRdyId idDeq @@ -3724,8 +3725,8 @@ adjustFIFOFields (vfi, fts) = renameField vft = [vft] in unzip $ concatMap renameField $ zip vfi fts -adjustFIFO0Fields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustFIFO0Fields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustFIFO0Fields (vfi, fts) = let (clk, rst) = case vfi of @@ -3737,8 +3738,8 @@ adjustFIFO0Fields (vfi, fts) = first_fts = ([], Nothing, []) in (first_vfi:vfi, first_fts:fts) -adjustSyncRegFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustSyncRegFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustSyncRegFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) -- XXX these are qualified Clock, not Prelude @@ -3750,16 +3751,16 @@ adjustSyncRegFields (vfi, fts) = ppReadable (vf_name vf)) in (map renameField vfi, fts) -adjustRWireFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustRWireFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustRWireFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) | (i `qualEq` idWHas) = vf { vf_name = unQualId $ mkRdyId idWGet } renameField vf = vf in (map renameField vfi, fts) -adjustRWire0Fields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustRWire0Fields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustRWire0Fields (vfi, fts) = let (clk, rst) = case vfi of @@ -3770,8 +3771,8 @@ adjustRWire0Fields (vfi, fts) = wget_fts = ([], Nothing, []) in (wget_vfi:vfi, wget_fts:fts) -adjustWireFields :: ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) +adjustWireFields :: ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustWireFields (vfi, fts) = let readId = id_read noPosition writeId = id_write noPosition @@ -3784,8 +3785,8 @@ adjustWireFields (vfi, fts) = in (map renameField vfi, fts) adjustPulseWireFields :: - ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustPulseWireFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) | (i `qualEq` idWSet) = vf { vf_name = unQualId idSend } @@ -3796,8 +3797,8 @@ adjustPulseWireFields (vfi, fts) = in (map renameField vfi, fts) adjustBypassWireFields :: - ([VFieldInfo], [([AType], Maybe AType, [AType])]) -> - ([VFieldInfo], [([AType], Maybe AType, [AType])]) + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) -> + ([VFieldInfo], [([[AType]], Maybe AType, [AType])]) adjustBypassWireFields (vfi, fts) = let renameField vf@(Method {vf_name = i }) | (i `qualEq` idWGet) = vf { vf_name = id_read noPosition } @@ -4222,7 +4223,7 @@ get_method_to_signal_map vmod = do case f of Method {} -> return () _ -> mzero -- failure, as in the guard function - port <- (vf_inputs f) ++ (vf_outputs f) ++ (maybeToList $ vf_enable f) + port <- vfMethodArgPorts f ++ (vf_outputs f) ++ (maybeToList $ vf_enable f) count <- case (vf_mult f) of 1 -> return Nothing k -> map Just [1..k] diff --git a/testsuite/bsc.evaluator/mkTest.atsexpand.expected b/testsuite/bsc.evaluator/mkTest.atsexpand.expected index 1dff74ee0..e359b2631 100644 --- a/testsuite/bsc.evaluator/mkTest.atsexpand.expected +++ b/testsuite/bsc.evaluator/mkTest.atsexpand.expected @@ -26,7 +26,7 @@ slots :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool slots_1 :: ABSTRACT: Prelude.VReg = RegUN @@ -41,7 +41,7 @@ slots_1 :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool ptr :: ABSTRACT: Prelude.VReg = RegUN @@ -56,7 +56,7 @@ ptr :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd5] [] - meth types=[([], Nothing, [Bit 5]), ([Bit 5], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 5]), ([[Bit 5]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 5 Q_OUT -> Prelude.Bit 5 pred :: ABSTRACT: Prelude.VReg = RegUN @@ -71,7 +71,7 @@ pred :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool -- AP rules diff --git a/testsuite/bsc.evaluator/mkTest.atsexpand.nolift.expandif.expected b/testsuite/bsc.evaluator/mkTest.atsexpand.nolift.expandif.expected index 2c1fcb19f..a65e6aae8 100644 --- a/testsuite/bsc.evaluator/mkTest.atsexpand.nolift.expandif.expected +++ b/testsuite/bsc.evaluator/mkTest.atsexpand.nolift.expandif.expected @@ -26,7 +26,7 @@ slots :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool slots_1 :: ABSTRACT: Prelude.VReg = RegUN @@ -41,7 +41,7 @@ slots_1 :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool ptr :: ABSTRACT: Prelude.VReg = RegUN @@ -56,7 +56,7 @@ ptr :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd5] [] - meth types=[([], Nothing, [Bit 5]), ([Bit 5], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 5]), ([[Bit 5]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 5 Q_OUT -> Prelude.Bit 5 pred :: ABSTRACT: Prelude.VReg = RegUN @@ -71,7 +71,7 @@ pred :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool -- AP rules diff --git a/testsuite/bsc.evaluator/sysITransformConstantAcrossEquals.atsexpand.expected b/testsuite/bsc.evaluator/sysITransformConstantAcrossEquals.atsexpand.expected index bdff286a1..65f86ddde 100644 --- a/testsuite/bsc.evaluator/sysITransformConstantAcrossEquals.atsexpand.expected +++ b/testsuite/bsc.evaluator/sysITransformConstantAcrossEquals.atsexpand.expected @@ -26,7 +26,7 @@ r :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd3] [] - meth types=[([], Nothing, [Bit 3]), ([Bit 3], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 3]), ([[Bit 3]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 3 Q_OUT -> Prelude.Bit 3 x :: ABSTRACT: Prelude.VReg = RegUN @@ -41,7 +41,7 @@ x :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd2] [] - meth types=[([], Nothing, [Bit 2]), ([Bit 2], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 2]), ([[Bit 2]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 2 Q_OUT -> Prelude.Bit 2 y :: ABSTRACT: Prelude.VReg = RegUN @@ -56,7 +56,7 @@ y :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd2] [] - meth types=[([], Nothing, [Bit 2]), ([Bit 2], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 2]), ([[Bit 2]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 2 Q_OUT -> Prelude.Bit 2 z :: ABSTRACT: Prelude.VReg = RegUN @@ -71,7 +71,7 @@ z :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd2] [] - meth types=[([], Nothing, [Bit 2]), ([Bit 2], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 2]), ([[Bit 2]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 2 Q_OUT -> Prelude.Bit 2 -- AP rules diff --git a/testsuite/bsc.evaluator/sysShiftMult.ats.expected b/testsuite/bsc.evaluator/sysShiftMult.ats.expected index c2250b423..24ebe97cc 100644 --- a/testsuite/bsc.evaluator/sysShiftMult.ats.expected +++ b/testsuite/bsc.evaluator/sysShiftMult.ats.expected @@ -26,7 +26,7 @@ x :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd32, 32'd17] [] - meth types=[([], Nothing, [Bit 32]), ([Bit 32], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 32]), ([[Bit 32]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 32 Q_OUT -> Prelude.Bit 32 y :: ABSTRACT: Prelude.VReg = RegN @@ -41,7 +41,7 @@ y :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd32, 32'd24] [] - meth types=[([], Nothing, [Bit 32]), ([Bit 32], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 32]), ([[Bit 32]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 32 Q_OUT -> Prelude.Bit 32 -- AP local definitions diff --git a/testsuite/bsc.names/signal_names/LiteralNum_ENotation.bsv.bsc-vcomp-out.expected b/testsuite/bsc.names/signal_names/LiteralNum_ENotation.bsv.bsc-vcomp-out.expected index 9e7784b8a..6913949ce 100644 --- a/testsuite/bsc.names/signal_names/LiteralNum_ENotation.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.names/signal_names/LiteralNum_ENotation.bsv.bsc-vcomp-out.expected @@ -30,7 +30,7 @@ rg_start :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd1, 1'd1] [] - meth types=[([], Nothing, [Bit 1]), ([Bit 1], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 1]), ([[Bit 1]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bool Q_OUT -> Prelude.Bool -- AP local definitions 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 e7a70d288..4d9324a41 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 @@ -35,7 +35,7 @@ rg :: ABSTRACT: PreludeBSV._PreludeBSV.VRWire103 = RWire [(WSET, WHAS), (WVAL, WGET)]) [32'd8, clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }] [] - meth types=[([Bit 8], Just (Bit 1), []), + meth types=[([[Bit 8]], Just (Bit 1), []), ([], Nothing, [Bit 1]), ([], Nothing, [Bit 8])] port types=WGET -> Prelude.Bit 8 diff --git a/testsuite/bsc.names/signal_names/MethodRead.bsv.bsc-vcomp-out.expected b/testsuite/bsc.names/signal_names/MethodRead.bsv.bsc-vcomp-out.expected index bdb5827d3..c6f2f84a8 100644 --- a/testsuite/bsc.names/signal_names/MethodRead.bsv.bsc-vcomp-out.expected +++ b/testsuite/bsc.names/signal_names/MethodRead.bsv.bsc-vcomp-out.expected @@ -29,7 +29,7 @@ rg :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd8] [] - meth types=[([], Nothing, [Bit 8]), ([Bit 8], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 8]), ([[Bit 8]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 8 Q_OUT -> Prelude.Bit 8 -- AP local definitions diff --git a/testsuite/bsc.scheduler/paths/paths.exp b/testsuite/bsc.scheduler/paths/paths.exp index 8f2c61f8f..9fc53ca68 100644 --- a/testsuite/bsc.scheduler/paths/paths.exp +++ b/testsuite/bsc.scheduler/paths/paths.exp @@ -682,38 +682,41 @@ find_regexp_fail mkVecNestedDeep.v {-> get_0_c_b} # Per-port loop discrimination: a genuine combinational loop confined to split # field p1 of method `get'. The cycle MUST be detected (G0032) and the cycle -# report must name exactly the offending split port -- "Argument 1"/"Return -# value 1" of `get' -- and NOT the sibling field p2's ports. Counterpart to the -# passing no-loop tests, proving per-port (not whole-method) cycle reporting. +# report must name exactly the offending split port -- "Argument 1 port 1"/ +# "Return value 1" of `get' -- and NOT the sibling field p2's port. Counterpart +# to the passing no-loop tests, proving per-port (not whole-method) cycle +# reporting. (Split fields stay one argument with multiple ports, so the +# offending field is "Argument 1 port 1", not a separate "Argument 1".) compile_verilog_fail_error LoopConfinedP1.bs G0032 -find_regexp LoopConfinedP1.bs.bsc-vcomp-out {Argument 1 of method `get'} +find_regexp LoopConfinedP1.bs.bsc-vcomp-out {Argument 1 port 1 of method `get'} find_regexp LoopConfinedP1.bs.bsc-vcomp-out {Return value 1 of method `get'} -find_regexp_fail LoopConfinedP1.bs.bsc-vcomp-out {Argument 2 of method `get'} +find_regexp_fail LoopConfinedP1.bs.bsc-vcomp-out {Argument 1 port 2 of method `get'} find_regexp_fail LoopConfinedP1.bs.bsc-vcomp-out {Return value 2 of method `get'} # Mirror image of LoopConfinedP1: the loop is confined to split field p2, so the -# G0032 cycle report must name "Argument 2"/"Return value 2" of `get' and NOT -# "Argument 1"/"Return value 1". Together with LoopConfinedP1 this proves the -# positional split-port index in the cycle report genuinely discriminates the -# offending field (it is not always reported as port "1"). +# G0032 cycle report must name "Argument 1 port 2"/"Return value 2" of `get' and +# NOT "Argument 1 port 1"/"Return value 1". Together with LoopConfinedP1 this +# proves the positional split-port index in the cycle report genuinely +# discriminates the offending field (it is not always reported as port "1"). compile_verilog_fail_error LoopConfinedP2.bs G0032 -find_regexp LoopConfinedP2.bs.bsc-vcomp-out {Argument 2 of method `get'} +find_regexp LoopConfinedP2.bs.bsc-vcomp-out {Argument 1 port 2 of method `get'} find_regexp LoopConfinedP2.bs.bsc-vcomp-out {Return value 2 of method `get'} -find_regexp_fail LoopConfinedP2.bs.bsc-vcomp-out {Argument 1 of method `get'} +find_regexp_fail LoopConfinedP2.bs.bsc-vcomp-out {Argument 1 port 1 of method `get'} find_regexp_fail LoopConfinedP2.bs.bsc-vcomp-out {Return value 1 of method `get'} # Per-split-port discrimination across MULTIPLE split arguments. Method `op' -# takes two split Pair arguments, so its input split ports are numbered 1,2 -# (arg1.p1, arg1.p2) and 3,4 (arg2.p1, arg2.p2). The loop is confined to -# arg2's field p1 == split input port 3, reaching result field p1 == return -# value 1. G0032 must name "Argument 3"/"Return value 1" of `op' and NOT -# "Argument 1", "Argument 2", or "Return value 2" -- demonstrating that the -# cycle report indexes the precise split port, not the whole method argument. +# takes two split Pair arguments, so it has split input ports "Argument 1 port +# 1/2" (arg1.p1/p2) and "Argument 2 port 1/2" (arg2.p1/p2). The loop is +# confined to arg2's field p1 == "Argument 2 port 1", reaching result field p1 +# == return value 1. G0032 must name "Argument 2 port 1"/"Return value 1" of +# `op' and NOT arg1's ports ("Argument 1 port 1/2") or "Return value 2" -- +# demonstrating that the cycle report indexes the precise split port AND the +# correct source argument, not the whole method argument. compile_verilog_fail_error LoopConfinedArg2.bs G0032 -find_regexp LoopConfinedArg2.bs.bsc-vcomp-out {Argument 3 of method `op'} +find_regexp LoopConfinedArg2.bs.bsc-vcomp-out {Argument 2 port 1 of method `op'} find_regexp LoopConfinedArg2.bs.bsc-vcomp-out {Return value 1 of method `op'} -find_regexp_fail LoopConfinedArg2.bs.bsc-vcomp-out {Argument 1 of method `op'} -find_regexp_fail LoopConfinedArg2.bs.bsc-vcomp-out {Argument 2 of method `op'} +find_regexp_fail LoopConfinedArg2.bs.bsc-vcomp-out {Argument 1 port 1 of method `op'} +find_regexp_fail LoopConfinedArg2.bs.bsc-vcomp-out {Argument 1 port 2 of method `op'} find_regexp_fail LoopConfinedArg2.bs.bsc-vcomp-out {Return value 2 of method `op'} } diff --git a/testsuite/bsc.scheduler/sat/SplitTupleMethodTest.bsv b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest.bsv new file mode 100644 index 000000000..40b6f0ac6 --- /dev/null +++ b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest.bsv @@ -0,0 +1,80 @@ +// Regression test for SMT disjointness conversion of method results that +// are split tuples (one Verilog output port per tuple element). +// +// In AExpr2Yices/AExpr2STP, an `ATupleSel` of an `AMethCall`/`AMethValue` +// must map the (1-based) tuple element index to the corresponding output +// port via `getMethodOutputPortAt`, which does +// `getMethodOutputPorts ... `genericIndex` (selIdx - 1)`. An earlier +// version omitted the `- 1`, which selected the wrong port and ran off the +// end of the port list (`genericIndex: index too large`) for the last +// element. This test forces both the value-method and the +// ActionValue-method arm through the SMT solver under both -sat backends. +// +// On this branch tuples do not split into per-element ports by default, so +// the method results are wrapped in ShallowSplit to give each tuple element +// its own output port (get_fst / get_snd). + +import SplitPorts::*; + +function Tuple2#(Bool, Bool) unwrap(ShallowSplit#(Tuple2#(Bool, Bool)) s); + case (s) matches + tagged ShallowSplit .p : return p; + endcase +endfunction + +interface ValSub; + method ShallowSplit#(Tuple2#(Bool, Bool)) get(Bit#(8) x); +endinterface + +(* synthesize *) +module mkValSub(ValSub); + method ShallowSplit#(Tuple2#(Bool, Bool)) get(Bit#(8) x); + return ShallowSplit(tuple2(x == 0, x == 1)); + endmethod +endmodule + +interface AVSub; + method ActionValue#(ShallowSplit#(Tuple2#(Bool, Bool))) get(); +endinterface + +(* synthesize *) +module mkAVSub(AVSub); + Reg#(Bit#(8)) r <- mkReg(0); + method ActionValue#(ShallowSplit#(Tuple2#(Bool, Bool))) get(); + r <= r + 1; + return ShallowSplit(tuple2(r == 0, r == 1)); + endmethod +endmodule + +(* synthesize *) +module sysSplitTupleMethodTest(); + ValSub vs <- mkValSub; + AVSub avs <- mkAVSub; + Reg#(Bit#(8)) x <- mkReg(0); + Reg#(UInt#(12)) uc <- mkReg(0); + Reg#(UInt#(12)) ud <- mkReg(0); + + // Value method: both tuple elements (output ports get_fst and get_snd of + // vs.get) appear in provably-disjoint rule guards, so the SMT solver must + // prove aa and ab are mutually exclusive (both write uc). + Tuple2#(Bool, Bool) p = unwrap(vs.get(x)); + Bool c1 = tpl_1(p); + Bool c2 = tpl_2(p); + + rule aa (c1 && !c2); + uc <= uc + 1; + endrule + rule ab (!c1 && c2); + uc <= uc + 2; + endrule + + // ActionValue method: both tuple elements (output ports get_fst and + // get_snd of avs.get) guard writes to a shared register, so the SMT solver + // must prove the two conditional updates are mutually exclusive. + rule cc; + let s <- avs.get(); + match {.d1, .d2} = unwrap(s); + if (d1 && !d2) ud <= ud + 1; + if (!d1 && d2) ud <= ud + 2; + endrule +endmodule diff --git a/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-stp.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-stp.bsv.bsc-sched-out.expected new file mode 100644 index 000000000..d176bb0d5 --- /dev/null +++ b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-stp.bsv.bsc-sched-out.expected @@ -0,0 +1,107 @@ +checking package dependencies +compiling SplitTupleMethodTest_sat-stp.bsv +code generation for mkValSub starts +=== schedule (SplitTupleMethodTest_sat-stp mkValSub): +parallel: [esposito: [get -> []]] +order: [get] + +----- + +=== resources (SplitTupleMethodTest_sat-stp mkValSub): +[] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-stp mkValSub): +SchedInfo [RDY_get CF [RDY_get, get], get CF get] [] [] [] + +----- + +Schedule dump file created: mkValSub.sched +=== Generated schedule for mkValSub === + +Method schedule +--------------- +Method: get +Ready signal: True +Conflict-free: get + +Logical execution order: get + +======================================== +Verilog file created: mkValSub.v +code generation for mkAVSub starts +=== schedule (SplitTupleMethodTest_sat-stp mkAVSub): +parallel: [esposito: [get -> []]] +order: [get] + +----- + +=== resources (SplitTupleMethodTest_sat-stp mkAVSub): +[(r.read, [(r.read, 1)]), (r.write, [(r.write r_PLUS_1___d2, 1)])] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-stp mkAVSub): +SchedInfo [RDY_get CF [RDY_get, get], get C get] [] [] [] + +----- + +Schedule dump file created: mkAVSub.sched +=== Generated schedule for mkAVSub === + +Method schedule +--------------- +Method: get +Ready signal: True +Conflicts: get + +Logical execution order: get + +======================================= +Verilog file created: mkAVSub.v +code generation for sysSplitTupleMethodTest starts +=== schedule (SplitTupleMethodTest_sat-stp sysSplitTupleMethodTest): +parallel: [esposito: [RL_aa -> [], RL_ab -> [], RL_cc -> []]] +order: [RL_aa, RL_ab, RL_cc] + +----- + +=== resources (SplitTupleMethodTest_sat-stp sysSplitTupleMethodTest): +[(avs.get, [(avs.get, 1)]), + (uc.read, [(uc.read, 1)]), + (uc.write, [(uc.write uc_PLUS_1___d7, 1), (uc.write uc_PLUS_2___d10, 1)]), + (ud.read, [(ud.read, 1)]), + (ud.write, [(if _dfoo1 then ud.write _dfoo2, 1)]), + (vs.get, [(vs.get x___d1, 1)]), + (x.read, [(x.read, 1)])] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-stp sysSplitTupleMethodTest): +SchedInfo [] [] [] [] + +----- + +Schedule dump file created: sysSplitTupleMethodTest.sched +=== Generated schedule for sysSplitTupleMethodTest === + +Rule schedule +------------- +Rule: aa +Predicate: vs.get(x)[1] && (! vs.get(x)[2]) +Blocking rules: (none) + +Rule: ab +Predicate: (! vs.get(x)[1]) && vs.get(x)[2] +Blocking rules: (none) + +Rule: cc +Predicate: True +Blocking rules: (none) + +Logical execution order: aa, ab, cc + +======================================================= +Verilog file created: sysSplitTupleMethodTest.v +All packages are up to date. diff --git a/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-yices.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-yices.bsv.bsc-sched-out.expected new file mode 100644 index 000000000..1ab67953f --- /dev/null +++ b/testsuite/bsc.scheduler/sat/SplitTupleMethodTest_sat-yices.bsv.bsc-sched-out.expected @@ -0,0 +1,107 @@ +checking package dependencies +compiling SplitTupleMethodTest_sat-yices.bsv +code generation for mkValSub starts +=== schedule (SplitTupleMethodTest_sat-yices mkValSub): +parallel: [esposito: [get -> []]] +order: [get] + +----- + +=== resources (SplitTupleMethodTest_sat-yices mkValSub): +[] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-yices mkValSub): +SchedInfo [RDY_get CF [RDY_get, get], get CF get] [] [] [] + +----- + +Schedule dump file created: mkValSub.sched +=== Generated schedule for mkValSub === + +Method schedule +--------------- +Method: get +Ready signal: True +Conflict-free: get + +Logical execution order: get + +======================================== +Verilog file created: mkValSub.v +code generation for mkAVSub starts +=== schedule (SplitTupleMethodTest_sat-yices mkAVSub): +parallel: [esposito: [get -> []]] +order: [get] + +----- + +=== resources (SplitTupleMethodTest_sat-yices mkAVSub): +[(r.read, [(r.read, 1)]), (r.write, [(r.write r_PLUS_1___d2, 1)])] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-yices mkAVSub): +SchedInfo [RDY_get CF [RDY_get, get], get C get] [] [] [] + +----- + +Schedule dump file created: mkAVSub.sched +=== Generated schedule for mkAVSub === + +Method schedule +--------------- +Method: get +Ready signal: True +Conflicts: get + +Logical execution order: get + +======================================= +Verilog file created: mkAVSub.v +code generation for sysSplitTupleMethodTest starts +=== schedule (SplitTupleMethodTest_sat-yices sysSplitTupleMethodTest): +parallel: [esposito: [RL_aa -> [], RL_ab -> [], RL_cc -> []]] +order: [RL_aa, RL_ab, RL_cc] + +----- + +=== resources (SplitTupleMethodTest_sat-yices sysSplitTupleMethodTest): +[(avs.get, [(avs.get, 1)]), + (uc.read, [(uc.read, 1)]), + (uc.write, [(uc.write uc_PLUS_1___d7, 1), (uc.write uc_PLUS_2___d10, 1)]), + (ud.read, [(ud.read, 1)]), + (ud.write, [(if _dfoo1 then ud.write _dfoo2, 1)]), + (vs.get, [(vs.get x___d1, 1)]), + (x.read, [(x.read, 1)])] + +----- + +=== vschedinfo (SplitTupleMethodTest_sat-yices sysSplitTupleMethodTest): +SchedInfo [] [] [] [] + +----- + +Schedule dump file created: sysSplitTupleMethodTest.sched +=== Generated schedule for sysSplitTupleMethodTest === + +Rule schedule +------------- +Rule: aa +Predicate: vs.get(x)[1] && (! vs.get(x)[2]) +Blocking rules: (none) + +Rule: ab +Predicate: (! vs.get(x)[1]) && vs.get(x)[2] +Blocking rules: (none) + +Rule: cc +Predicate: True +Blocking rules: (none) + +Logical execution order: aa, ab, cc + +======================================================= +Verilog file created: sysSplitTupleMethodTest.v +All packages are up to date. diff --git a/testsuite/bsc.scheduler/sat/sat.exp b/testsuite/bsc.scheduler/sat/sat.exp index 615228784..c617e0816 100644 --- a/testsuite/bsc.scheduler/sat/sat.exp +++ b/testsuite/bsc.scheduler/sat/sat.exp @@ -12,7 +12,7 @@ set sources [list \ ArraySelectShortIndexTest ArraySelectLongIndexTest \ ArraySelectImplCondTest \ ParamBoolTest ParamBitsTest \ - Word64Test + Word64Test SplitTupleMethodTest ] set solvers [list yices stp] diff --git a/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest.atsexpand.expected b/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest.atsexpand.expected index f8a25e7e7..89c7fc81d 100644 --- a/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest.atsexpand.expected +++ b/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest.atsexpand.expected @@ -26,7 +26,7 @@ b :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd16, 16'd11] [] - meth types=[([], Nothing, [Bit 16]), ([Bit 16], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 16]), ([[Bit 16]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 16 Q_OUT -> Prelude.Bit 16 -- AP rules diff --git a/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest2.atsexpand.expected b/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest2.atsexpand.expected index 07d0442fc..397f16c2d 100644 --- a/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest2.atsexpand.expected +++ b/testsuite/bsc.syntax/bsv05/statename/sysStateNameTest2.atsexpand.expected @@ -26,7 +26,7 @@ b :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd16, 16'd11] [] - meth types=[([], Nothing, [Bit 16]), ([Bit 16], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 16]), ([[Bit 16]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 16 Q_OUT -> Prelude.Bit 16 -- AP rules diff --git a/testsuite/bsc.syntax/bsv05/statename/sysUseMod2.atsexpand.expected b/testsuite/bsc.syntax/bsv05/statename/sysUseMod2.atsexpand.expected index d1c6302b1..e1085784a 100644 --- a/testsuite/bsc.syntax/bsv05/statename/sysUseMod2.atsexpand.expected +++ b/testsuite/bsc.syntax/bsv05/statename/sysUseMod2.atsexpand.expected @@ -27,7 +27,7 @@ the_e_the_r :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd32, 32'd0] [] - meth types=[([], Nothing, [Bit 32]), ([Bit 32], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 32]), ([[Bit 32]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 32 Q_OUT -> Prelude.Bit 32 -- AP rules diff --git a/testsuite/bsc.syntax/bsv05/statename/sysUseMod2Arrow.atsexpand.expected b/testsuite/bsc.syntax/bsv05/statename/sysUseMod2Arrow.atsexpand.expected index 392d85adb..ab30b3165 100644 --- a/testsuite/bsc.syntax/bsv05/statename/sysUseMod2Arrow.atsexpand.expected +++ b/testsuite/bsc.syntax/bsv05/statename/sysUseMod2Arrow.atsexpand.expected @@ -27,7 +27,7 @@ e_r :: ABSTRACT: Prelude.VReg = RegN []) [clock { osc: CLK gate: 1'd1 }, reset { wire: RST_N }, 32'd32, 32'd0] [] - meth types=[([], Nothing, [Bit 32]), ([Bit 32], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 32]), ([[Bit 32]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 32 Q_OUT -> Prelude.Bit 32 -- AP rules diff --git a/testsuite/bsc.typechecker/dontcare/DummyInRuleQual.bs.bsc-vcomp-out.expected b/testsuite/bsc.typechecker/dontcare/DummyInRuleQual.bs.bsc-vcomp-out.expected index 48db7e8b2..fed6dd883 100644 --- a/testsuite/bsc.typechecker/dontcare/DummyInRuleQual.bs.bsc-vcomp-out.expected +++ b/testsuite/bsc.typechecker/dontcare/DummyInRuleQual.bs.bsc-vcomp-out.expected @@ -33,7 +33,7 @@ r :: ABSTRACT: Prelude.VReg = RegUN []) [clock { osc: CLK gate: 1'd1 }, 32'd12] [] - meth types=[([], Nothing, [Bit 12]), ([Bit 12], Just (Bit 1), [])] + meth types=[([], Nothing, [Bit 12]), ([[Bit 12]], Just (Bit 1), [])] port types=D_IN -> Prelude.Bit 12 Q_OUT -> Prelude.Bit 12 -- AP local definitions diff --git a/testsuite/bsc.verilog/portprops/IncorrectPortMapping.bsv b/testsuite/bsc.verilog/portprops/IncorrectPortMapping.bsv new file mode 100644 index 000000000..7ff5bd4ad --- /dev/null +++ b/testsuite/bsc.verilog/portprops/IncorrectPortMapping.bsv @@ -0,0 +1,34 @@ +// Regression test for a method-multiplicity port-mapping bug (see PR #928). +// +// When an imported (BVI) method has multiplicity > 1 and more than one +// argument, the map between the method-internal port names and the actual +// Verilog port names is built in createMapForOneMeth (BackendNamingConventions). +// The method side numbers the ports with the multiplicity copy as the outer +// loop and the arguments inner; the Verilog side must do the same (matching the +// order AVerilogUtil emits). A previous version expanded the multiplicity with +// the ports outer and the copy inner, which transposed the two lists and +// produced mismatched connections, e.g. ".A_2(someModule$A_3)" instead of +// ".A_2(someModule$A_2)". +// +// This checks that each Verilog port of the instantiated submodule connects to +// the matching internal wire (identity mapping). + +package IncorrectPortMapping; + +interface SomeInterface; + method Action someMethod(bit a, bit b); +endinterface + +import "BVI" SomeVerilogModule = +module mkSomeVerilogModule (SomeInterface); + method someMethod[4](A, B) enable(ENABLE); + + schedule someMethod CF someMethod; +endmodule + +(* synthesize *) +module mkExample (); + SomeInterface someModule <- mkSomeVerilogModule(); +endmodule + +endpackage diff --git a/testsuite/bsc.verilog/portprops/portprops.exp b/testsuite/bsc.verilog/portprops/portprops.exp index da3f227f1..06a74dd0c 100644 --- a/testsuite/bsc.verilog/portprops/portprops.exp +++ b/testsuite/bsc.verilog/portprops/portprops.exp @@ -143,5 +143,18 @@ compare_file InoutProps_UnusedArgBVI.bsv.bsc-vcomp-out # ---------- +# Method multiplicity port mapping (PR #928): an imported method with +# multiplicity > 1 and more than one argument must connect each Verilog port to +# the matching internal wire (multiplicity copy outer, arguments inner). This +# guards against a transposed mapping that connected e.g. .A_2 to A_3. +compile_verilog_pass IncorrectPortMapping.bsv +find_regexp mkExample.v {\.A_2\(someModule\$A_2\)} +find_regexp mkExample.v {\.B_1\(someModule\$B_1\)} +find_regexp mkExample.v {\.B_3\(someModule\$B_3\)} +find_regexp_fail mkExample.v {\.A_2\(someModule\$A_3\)} +find_regexp_fail mkExample.v {\.B_1\(someModule\$A_2\)} + +# ---------- + } diff --git a/testsuite/bsc.verilog/splitports/NoinlineDeepSplit.bs b/testsuite/bsc.verilog/splitports/NoinlineDeepSplit.bs new file mode 100644 index 000000000..e0340b786 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/NoinlineDeepSplit.bs @@ -0,0 +1,43 @@ +package NoinlineDeepSplit where + +import Vector +import BuildVector +import SplitPorts + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +struct Bar = + v :: Vector 3 Bool + w :: (Bool, UInt 16) + z :: Foo + deriving (Bits) + +-- A direct (deep) SplitPorts instance on the struct, delegating to the generic +-- deep-splitting helpers (no DeepSplit newtype). Bar recurses fully: vector +-- elements, tuple elements, and the nested Foo's fields all become ports. +instance SplitPorts Bar (DeepPortsOf Bar) where + splitPorts = deepSplitPorts + unsplitPorts = deepUnsplitPorts + portNames = deepSplitPortNames + +{-# noinline tweak #-} +tweak :: Bar -> Bar +tweak b = b { z = Foo { x = b.z.y; y = b.z.x; }; + w = (not (b.w.fst), b.w.snd + 1); } + +{-# synthesize sysNoinlineDeepSplit #-} +sysNoinlineDeepSplit :: Module Empty +sysNoinlineDeepSplit = + module + r :: Reg (Int 8) <- mkReg 0 + rules + when True ==> r := r + 1 + when r == 5 ==> + let b = tweak (Bar { v = vec True False True; + w = (False, 100); + z = Foo { x = 7; y = 9; } }) + in $display "zx=%d zy=%d wb=%d wn=%d" b.z.x b.z.y b.w.fst b.w.snd + when r == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/NoinlineSplit.bs b/testsuite/bsc.verilog/splitports/NoinlineSplit.bs new file mode 100644 index 000000000..ad701073e --- /dev/null +++ b/testsuite/bsc.verilog/splitports/NoinlineSplit.bs @@ -0,0 +1,33 @@ +package NoinlineSplit where + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +-- A *direct* SplitPorts instance on the struct (no ShallowSplit newtype): Foo +-- splits into two ports named after its fields. The noinline function uses Foo +-- directly as its argument and result type, so module_swapFoo should expose +-- split input ports (swapFoo__x / _y) and split output ports +-- (swapFoo_x / swapFoo_y), and the instantiation must connect the argument +-- value and result to those same (split) port names. +instance SplitPorts Foo (Port (Int 8), Port (Int 8)) where + splitPorts foo = (Port foo.x, Port foo.y) + unsplitPorts (Port x, Port y) = Foo { x = x; y = y; } + portNames _ base = Cons (base +++ "_x") (Cons (base +++ "_y") Nil) + +{-# noinline swapFoo #-} +swapFoo :: Foo -> Foo +swapFoo f = Foo { x = f.y; y = f.x; } + +{-# synthesize sysNoinlineSplit #-} +sysNoinlineSplit :: Module Empty +sysNoinlineSplit = + module + r :: Reg (Int 8) <- mkReg 0 + rules + when True ==> r := r + 1 + when r == 5 ==> + let g = swapFoo (Foo { x = 3; y = 4; }) + in $display "x=%d y=%d" g.x g.y + when r == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/NoinlineSplitMulti.bs b/testsuite/bsc.verilog/splitports/NoinlineSplitMulti.bs new file mode 100644 index 000000000..35a18bdf1 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/NoinlineSplitMulti.bs @@ -0,0 +1,33 @@ +package NoinlineSplitMulti where + +struct Foo = + x :: Int 8 + y :: Int 8 + deriving (Bits) + +-- Direct SplitPorts instance on the struct (no ShallowSplit newtype). +instance SplitPorts Foo (Port (Int 8), Port (Int 8)) where + splitPorts foo = (Port foo.x, Port foo.y) + unsplitPorts (Port x, Port y) = Foo { x = x; y = y; } + portNames _ base = Cons (base +++ "_x") (Cons (base +++ "_y") Nil) + +-- two split arguments and one unsplit argument: each argument's value is +-- connected to its own port(s) (the input ports are grouped per argument). +-- The split arguments are destructured by a pattern in the function head, so +-- they have no argument name and get the default _ base name. +{-# noinline combine #-} +combine :: Foo -> Int 8 -> Foo -> Foo +combine (Foo { x = ax; y = ay }) k (Foo { x = bx; y = by }) = + Foo { x = ax + bx + k; y = ay + by; } + +{-# synthesize sysNoinlineSplitMulti #-} +sysNoinlineSplitMulti :: Module Empty +sysNoinlineSplitMulti = + module + r :: Reg (Int 8) <- mkReg 0 + rules + when True ==> r := r + 1 + when r == 5 ==> + let g = combine (Foo { x = 1; y = 2; }) 10 (Foo { x = 3; y = 4; }) + in $display "x=%d y=%d" g.x g.y + when r == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/NoinlineSplitTuple.bs b/testsuite/bsc.verilog/splitports/NoinlineSplitTuple.bs new file mode 100644 index 000000000..2c7e3410f --- /dev/null +++ b/testsuite/bsc.verilog/splitports/NoinlineSplitTuple.bs @@ -0,0 +1,21 @@ +package NoinlineSplitTuple where + +import SplitPorts + +-- ShallowSplit of a (2-)tuple result: the ports are named after the tuple +-- fields (fst, snd). +{-# noinline divmod #-} +divmod :: Int 8 -> Int 8 -> ShallowSplit (Int 8, Bool) +divmod a b = ShallowSplit (a + b, a == b) + +{-# synthesize sysNoinlineSplitTuple #-} +sysNoinlineSplitTuple :: Module Empty +sysNoinlineSplitTuple = + module + r :: Reg (Int 8) <- mkReg 0 + rules + when True ==> r := r + 1 + when r == 5 ==> + case divmod 7 3 of + ShallowSplit (s, e) -> $display "s=%d e=%d" s e + when r == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/NoinlineSplitTuple3.bs b/testsuite/bsc.verilog/splitports/NoinlineSplitTuple3.bs new file mode 100644 index 000000000..31c65a24b --- /dev/null +++ b/testsuite/bsc.verilog/splitports/NoinlineSplitTuple3.bs @@ -0,0 +1,24 @@ +package NoinlineSplitTuple3 where + +import SplitPorts + +-- ShallowSplit of a 3-element tuple result: shallow-splitting produces a +-- `fst` port and a combined `snd` port (the remaining elements packed +-- together). Reading the inner elements of `snd` selects bits out of an +-- already-sliced wire, which previously produced an illegal chained Verilog +-- index (wire[a:b][c:d]). +{-# noinline triple #-} +triple :: Int 8 -> Int 8 -> ShallowSplit (Int 8, Int 8, Bool) +triple a b = ShallowSplit (a + b, a - b, a == b) + +{-# synthesize sysNoinlineSplitTuple3 #-} +sysNoinlineSplitTuple3 :: Module Empty +sysNoinlineSplitTuple3 = + module + r :: Reg (Int 8) <- mkReg 0 + rules + when True ==> r := r + 1 + when r == 5 ==> + case triple 7 3 of + ShallowSplit (s, d, e) -> $display "s=%d d=%d e=%d" s d e + when r == 6 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/SplitArgSlice.bs b/testsuite/bsc.verilog/splitports/SplitArgSlice.bs new file mode 100644 index 000000000..997622621 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SplitArgSlice.bs @@ -0,0 +1,42 @@ +package SplitArgSlice where + +import SplitPorts + +struct Inner = + p :: Bit 8 + q :: Bit 8 + deriving (Bits) + +struct Outer = + a :: Bit 8 + inner :: Inner + deriving (Bits) + +-- A submodule (NOT a noinline function) whose method argument is shallow-split: +-- `a` gets its own port and the nested `inner` struct gets one combined port. +interface Sub = + put :: ShallowSplit Outer -> Action + +{-# synthesize mkSub #-} +mkSub :: Module Sub +mkSub = + module + interface + put (ShallowSplit o) = $display "a=%0d p=%0d q=%0d" o.a o.inner.p o.inner.q + +-- The caller passes a non-constant Outer value (derived from register state) to +-- the submodule's split argument. The value is materialized as a literal-tuple +-- def, which is emitted as one wire per element, so each split input port is +-- driven directly by its element wire -- no bit-select of a combined wide wire. +-- (An ordinary synthesized submodule, not a noinline function.) +{-# synthesize sysSplitArgSlice #-} +sysSplitArgSlice :: Module Empty +sysSplitArgSlice = + module + s :: Sub <- mkSub + c :: Reg (Bit 8) <- mkReg 0 + rules + when True ==> c := c + 1 + when c < 4 ==> + s.put (ShallowSplit (Outer { a = c; inner = Inner { p = c + 1; q = c + 2 } })) + when c == 4 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/SplitInputRegs.bs b/testsuite/bsc.verilog/splitports/SplitInputRegs.bs new file mode 100644 index 000000000..a452444c8 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SplitInputRegs.bs @@ -0,0 +1,44 @@ +package SplitInputRegs where + +import SplitPorts + +-- A flat struct whose fields are leaves: shallow-splitting gives one port per +-- field (no combined port), so each element of the split argument can be wired +-- straight to its own register with no slicing or concat. +struct Pair = + x :: Bit 8 + y :: Bit 8 + deriving (Bits) + +interface Ifc = + put :: ShallowSplit Pair -> Action + getX :: Bit 8 + getY :: Bit 8 + +{-# synthesize mkSplitInputRegs #-} +mkSplitInputRegs :: Module Ifc +mkSplitInputRegs = + module + rx :: Reg (Bit 8) <- mkReg 0 + ry :: Reg (Bit 8) <- mkReg 0 + interface + -- each element of the split input goes to its own register + put (ShallowSplit s) = do + rx := s.x + ry := s.y + getX = rx + getY = ry + +{-# synthesize sysSplitInputRegs #-} +sysSplitInputRegs :: Module Empty +sysSplitInputRegs = + module + m :: Ifc <- mkSplitInputRegs + c :: Reg (Bit 8) <- mkReg 0 + rules + when True ==> c := c + 1 + when c < 3 ==> + m.put (ShallowSplit (Pair { x = c + 10; y = c + 20 })) + when c == 3 ==> do + $display "x=%0d y=%0d" m.getX m.getY + $finish diff --git a/testsuite/bsc.verilog/splitports/SplitTupleSensitivity.bs b/testsuite/bsc.verilog/splitports/SplitTupleSensitivity.bs new file mode 100644 index 000000000..1ba394248 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SplitTupleSensitivity.bs @@ -0,0 +1,38 @@ +package SplitTupleSensitivity where + +import SplitPorts + +-- A noinline function returns a tuple via SplitPorts, so the result is bound to +-- a def that vDefMpd splits into one wire per element. Reading those elements +-- inside a case that drives a register puts the element selects into an +-- always-block sensitivity list -- which is built by aIds, not vExpr. aIds must +-- name the element wires the same way vExpr does (tupleElemVId), otherwise the +-- sensitivity list references the undeclared whole-tuple def name and the +-- generated Verilog fails to elaborate (iverilog: "Unable to bind ..."). +{-# noinline pick #-} +pick :: Bit 8 -> ShallowSplit (Bit 8, Bit 8) +pick x = ShallowSplit (x + 1, x + 2) + +{-# synthesize sysSplitTupleSensitivity #-} +sysSplitTupleSensitivity :: Module Empty +sysSplitTupleSensitivity = + module + sel :: Reg (Bit 3) <- mkReg 0 + out :: Reg (Bit 8) <- mkReg 0 + rules + "step": when (sel < 7) ==> + case pick (zeroExtend sel) of + ShallowSplit (a, b) -> do + -- a multi-arm case on a register selector becomes a Verilog `always` + -- case block; its sensitivity list mentions the tuple elements a, b + out := case sel of + 0 -> a + 1 -> b + 2 -> a + b + 3 -> a - b + 4 -> a & b + 5 -> a | b + _ -> a ^ b + $display "sel=%0d out=%0d" sel out + sel := sel + 1 + "done": when (sel == 7) ==> $finish diff --git a/testsuite/bsc.verilog/splitports/splitports.exp b/testsuite/bsc.verilog/splitports/splitports.exp index 12c8fa783..94997b4c4 100644 --- a/testsuite/bsc.verilog/splitports/splitports.exp +++ b/testsuite/bsc.verilog/splitports/splitports.exp @@ -92,6 +92,137 @@ if { $vtest == 1 } { find_regexp mkSomeArgNamesSplitTest.v {input putFooBar_2_b;} } +# ---------- +# Port splitting for the arguments and results of noinline functions. +# The generated module_ exposes split input/output ports, and the caller's +# instantiation connects the argument values and result to those same names +# (verified in both the Verilog and Bluesim backends). + +# Argument and result are a struct with a direct (custom) SplitPorts instance +# -- no ShallowSplit newtype. Foo splits into two ports named after its fields. +test_c_veri_bs_modules NoinlineSplit {module_swapFoo} +if { $vtest == 1 } { + find_regexp module_swapFoo.v {input \[7 : 0\] swapFoo_f_x;} + find_regexp module_swapFoo.v {input \[7 : 0\] swapFoo_f_y;} + find_regexp module_swapFoo.v {output \[7 : 0\] swapFoo_x;} + find_regexp module_swapFoo.v {output \[7 : 0\] swapFoo_y;} + find_regexp sysNoinlineSplit.v {\.swapFoo_f_x\(} + find_regexp sysNoinlineSplit.v {\.swapFoo_f_y\(} + find_regexp sysNoinlineSplit.v {\.swapFoo_x\(} + find_regexp sysNoinlineSplit.v {\.swapFoo_y\(} +} + +# Several arguments, some split (direct SplitPorts instance) and some not: +# each argument's value is connected to its own port(s) (the input ports are +# grouped per argument). The split arguments are destructured by a pattern in +# the function head, so they have no name and get the default _ base name. +test_c_veri_bs_modules NoinlineSplitMulti {module_combine} +if { $vtest == 1 } { + find_regexp module_combine.v {input \[7 : 0\] combine__a1000_x;} + find_regexp module_combine.v {input \[7 : 0\] combine__a1000_y;} + find_regexp module_combine.v {input \[7 : 0\] combine_k;} + find_regexp module_combine.v {input \[7 : 0\] combine__a1002_x;} + find_regexp module_combine.v {input \[7 : 0\] combine__a1002_y;} + find_regexp module_combine.v {output \[7 : 0\] combine_x;} + find_regexp module_combine.v {output \[7 : 0\] combine_y;} + # the unsplit argument connects directly; the split ones are sliced + find_regexp sysNoinlineSplitMulti.v {\.combine_k\(8'd10\)} + find_regexp sysNoinlineSplitMulti.v {\.combine__a1000_x\(} + find_regexp sysNoinlineSplitMulti.v {\.combine__a1002_y\(} +} + +# Argument and result split *recursively* via a direct (deep) SplitPorts +# instance -- no DeepSplit newtype. A vector, a tuple, and a nested struct all +# become separate ports. +test_c_veri_bs_modules NoinlineDeepSplit {module_tweak} +if { $vtest == 1 } { + find_regexp module_tweak.v {input tweak_b_v_0;} + find_regexp module_tweak.v {input tweak_b_v_2;} + find_regexp module_tweak.v {input tweak_b_w_1;} + find_regexp module_tweak.v {input \[15 : 0\] tweak_b_w_2;} + find_regexp module_tweak.v {input \[7 : 0\] tweak_b_z_x;} + find_regexp module_tweak.v {input \[7 : 0\] tweak_b_z_y;} + find_regexp module_tweak.v {output tweak_v_0;} + find_regexp module_tweak.v {output \[15 : 0\] tweak_w_2;} + find_regexp module_tweak.v {output \[7 : 0\] tweak_z_x;} + find_regexp sysNoinlineDeepSplit.v {\.tweak_b_z_x\(} + find_regexp sysNoinlineDeepSplit.v {\.tweak_z_y\(} +} + +# Result is a tuple split into ports named after the tuple fields (fst, snd), +# using the ShallowSplit newtype. +test_c_veri_bs_modules NoinlineSplitTuple {module_divmod} +if { $vtest == 1 } { + find_regexp module_divmod.v {output \[7 : 0\] divmod_fst;} + find_regexp module_divmod.v {output divmod_snd;} + find_regexp sysNoinlineSplitTuple.v {\.divmod_fst\(} + find_regexp sysNoinlineSplitTuple.v {\.divmod_snd\(} +} + +# Result is a 3-element tuple (ShallowSplit newtype): the shallow split peels +# off the first field (fst) and leaves the rest in one combined port (snd). +# The result is reassembled as one wire per top-level field, driven directly by +# the output ports (no slicing of a wide result wire). The combined snd port is +# its own element wire, so reading the inner Int 8 out of it is a single index on +# that wire -- never an illegal chained index like wire[8:0][8:1]. +test_c_veri_bs_modules NoinlineSplitTuple3 {module_triple} +if { $vtest == 1 } { + find_regexp module_triple.v {output \[7 : 0\] triple_fst;} + find_regexp module_triple.v {output \[8 : 0\] triple_snd;} + # each result field is its own wire, driven directly by its output port + find_regexp sysNoinlineSplitTuple3.v {\.triple_fst\(triple__f1_1\)} + find_regexp sysNoinlineSplitTuple3.v {\.triple_snd\(triple__f1_2\)} + # the inner Int 8 is read directly out of the snd element wire (a single + # index on that wire, not a slice of a slice) + find_regexp sysNoinlineSplitTuple3.v {triple__f1_2\[8:1\]} + find_regexp_fail sysNoinlineSplitTuple3.v {\]\[} +} + +# An ordinary submodule (NOT a noinline function) whose Action method takes a +# shallow-split struct argument and writes each element to its own register. +# The struct's fields are leaves, so each split input port is wired straight to +# its register -- no slicing or concat. +test_c_veri SplitInputRegs +if { $vtest == 1 } { + find_regexp mkSplitInputRegs.v {input \[7 : 0\] put_1_x;} + find_regexp mkSplitInputRegs.v {input \[7 : 0\] put_1_y;} + find_regexp mkSplitInputRegs.v {rx[$]D_IN = put_1_x ;} + find_regexp mkSplitInputRegs.v {ry[$]D_IN = put_1_y ;} + # each element drives its register directly -- the ports are never sliced + find_regexp_fail mkSplitInputRegs.v {put_1_[xy]\[} +} + +# A non-constant struct value (derived from register state) is passed to a +# submodule's shallow-split argument. The tuple value is a literal-tuple def, so +# it is emitted as one wire per element and each split input port is driven +# directly by its element wire -- no slicing of a combined wide wire. (This is an +# ordinary synthesized submodule, not noinline.) +test_c_veri SplitArgSlice +if { $vtest == 1 } { + # the submodule's shallow-split argument: leaf `a` on its own port, the + # nested `inner` struct combined into one port + find_regexp mkSub.v {input \[7 : 0\] put_1_a;} + find_regexp mkSub.v {input \[15 : 0\] put_1_inner;} + # the Outer value is split into per-element wires (..._1 / ..._2) and each + # split port is driven directly by its element wire (no bit-select) + find_regexp sysSplitArgSlice.v {s[$]put_1_a = [A-Za-z0-9_]+_1 ;} + find_regexp sysSplitArgSlice.v {s[$]put_1_inner = [A-Za-z0-9_]+_2 ;} + find_regexp_fail sysSplitArgSlice.v {\[[0-9]+:[0-9]+\]} +} + +# A split tuple result read inside a case that drives a register: the case +# becomes an always-block whose sensitivity list is built by aIds (not vExpr). +# aIds must name the element wires the same way vExpr does (pick__f1_1/_2), or +# the sensitivity list references the undeclared whole-tuple def name pick__f1 +# (regression: aIds had no ATupleSel case and this internal-errored). +test_c_veri SplitTupleSensitivity +if { $vtest == 1 } { + find_regexp sysSplitTupleSensitivity.v {pick__f1_1 or pick__f1_2} + find_regexp_fail sysSplitTupleSensitivity.v {or pick__f1[ )]} +} + +# ---------- + compile_verilog_fail_error TooManyArgNames.bs S0015 compare_file TooManyArgNames.bs.bsc-vcomp-out diff --git a/testsuite/bsc.verilog/splitports/sysNoinlineDeepSplit.out.expected b/testsuite/bsc.verilog/splitports/sysNoinlineDeepSplit.out.expected new file mode 100644 index 000000000..ecfd943b5 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysNoinlineDeepSplit.out.expected @@ -0,0 +1 @@ +zx= 9 zy= 7 wb=1 wn= 101 diff --git a/testsuite/bsc.verilog/splitports/sysNoinlineSplit.out.expected b/testsuite/bsc.verilog/splitports/sysNoinlineSplit.out.expected new file mode 100644 index 000000000..841b1264a --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysNoinlineSplit.out.expected @@ -0,0 +1 @@ +x= 4 y= 3 diff --git a/testsuite/bsc.verilog/splitports/sysNoinlineSplitMulti.out.expected b/testsuite/bsc.verilog/splitports/sysNoinlineSplitMulti.out.expected new file mode 100644 index 000000000..6e5006ddb --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysNoinlineSplitMulti.out.expected @@ -0,0 +1 @@ +x= 14 y= 6 diff --git a/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple.out.expected b/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple.out.expected new file mode 100644 index 000000000..2f61af7b5 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple.out.expected @@ -0,0 +1 @@ +s= 10 e=0 diff --git a/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple3.out.expected b/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple3.out.expected new file mode 100644 index 000000000..563089657 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysNoinlineSplitTuple3.out.expected @@ -0,0 +1 @@ +s= 10 d= 4 e=0 diff --git a/testsuite/bsc.verilog/splitports/sysSplitArgSlice.out.expected b/testsuite/bsc.verilog/splitports/sysSplitArgSlice.out.expected new file mode 100644 index 000000000..7743e6218 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSplitArgSlice.out.expected @@ -0,0 +1,4 @@ +a=0 p=1 q=2 +a=1 p=2 q=3 +a=2 p=3 q=4 +a=3 p=4 q=5 diff --git a/testsuite/bsc.verilog/splitports/sysSplitInputRegs.out.expected b/testsuite/bsc.verilog/splitports/sysSplitInputRegs.out.expected new file mode 100644 index 000000000..f8c2ee7bd --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSplitInputRegs.out.expected @@ -0,0 +1 @@ +x=12 y=22 diff --git a/testsuite/bsc.verilog/splitports/sysSplitTupleSensitivity.out.expected b/testsuite/bsc.verilog/splitports/sysSplitTupleSensitivity.out.expected new file mode 100644 index 000000000..1bf28fc8f --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSplitTupleSensitivity.out.expected @@ -0,0 +1,7 @@ +sel=0 out=0 +sel=1 out=1 +sel=2 out=3 +sel=3 out=7 +sel=4 out=255 +sel=5 out=4 +sel=6 out=7 From b3091d51b382dbe473b7f77d5072b43f44a5591b Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 10 Jul 2026 18:49:23 -0700 Subject: [PATCH 02/18] Port-splitting part 5: SplitVector and SplitPorts utility functions This is a squash merge of GitHub PR 983. Add SplitVector utility. The package only depends on the SplitPorts *class* (defined in the Prelude), not on anything in the SplitPorts package. Add "unShallowSplit", "unDeepSplit", and "unNoSplit" utility functions. --- src/Libraries/Base1/SplitPorts.bs | 7 + src/Libraries/Base1/SplitVector.bs | 60 +++++++ src/Libraries/Base1/depends.mk | 1 + .../bsc.verilog/splitports/SplitVectorOps.bs | 76 ++++++++ .../splitports/SplitVectorPorts.bs | 162 ++++++++++++++++++ .../bsc.verilog/splitports/splitports.exp | 51 ++++++ .../splitports/sysSplitVectorOps.out.expected | 13 ++ .../sysSplitVectorPorts.out.expected | 12 ++ 8 files changed, 382 insertions(+) create mode 100644 src/Libraries/Base1/SplitVector.bs create mode 100644 testsuite/bsc.verilog/splitports/SplitVectorOps.bs create mode 100644 testsuite/bsc.verilog/splitports/SplitVectorPorts.bs create mode 100644 testsuite/bsc.verilog/splitports/sysSplitVectorOps.out.expected create mode 100644 testsuite/bsc.verilog/splitports/sysSplitVectorPorts.out.expected diff --git a/src/Libraries/Base1/SplitPorts.bs b/src/Libraries/Base1/SplitPorts.bs index 265257f9b..be53a46e0 100644 --- a/src/Libraries/Base1/SplitPorts.bs +++ b/src/Libraries/Base1/SplitPorts.bs @@ -7,10 +7,17 @@ import Vector -- Newtype tags to indicate that a types should be split (recursively or not) into ports data ShallowSplit a = ShallowSplit a +unShallowSplit :: ShallowSplit a -> a +unShallowSplit (ShallowSplit x) = x + data DeepSplit a = DeepSplit a +unDeepSplit :: DeepSplit a -> a +unDeepSplit (DeepSplit x) = x -- Tag to indicate that the DeepSplitPorts recursion should terminate data NoSplit a = NoSplit a +unNoSplit :: NoSplit a -> a +unNoSplit (NoSplit x) = x instance SplitPorts (ShallowSplit a) (ShallowPortsOf a) where splitPorts (ShallowSplit x) = shallowSplitPorts x diff --git a/src/Libraries/Base1/SplitVector.bs b/src/Libraries/Base1/SplitVector.bs new file mode 100644 index 000000000..a33b07f07 --- /dev/null +++ b/src/Libraries/Base1/SplitVector.bs @@ -0,0 +1,60 @@ +package SplitVector where + +-- A newtype wrapper for a Vector that recursively splits its elements into +-- the corresponding SplitPorts ports. + +import qualified List +import Vector +import CShow +import Foldable +import Traversable + +data SplitVector n a = SplitVector (Vector n a) + deriving (Eq, Ord, Bits, CShow, DefaultValue, Bounded) + +unSplitVector :: SplitVector n a -> Vector n a +unSplitVector (SplitVector v) = v + +instance Functor (SplitVector n) where + fmap f (SplitVector v) = SplitVector (fmap f v) + +instance Applicative (SplitVector n) where + pure x = SplitVector (pure x) + (<*>) (SplitVector f) (SplitVector v) = SplitVector (f <*> v) + liftA2 f (SplitVector v1) (SplitVector v2) = SplitVector (liftA2 f v1 v2) + +instance Foldable (SplitVector n) where + foldr f z (SplitVector v) = foldr f z v + foldl f z (SplitVector v) = foldl f z v + foldrM f z (SplitVector v) = foldrM f z v + foldlM f z (SplitVector v) = foldlM f z v + traverse_ f (SplitVector v) = traverse_ f v + sequenceA_ (SplitVector v) = sequenceA_ v + mapM_ f (SplitVector v) = mapM_ f v + sequence_ (SplitVector v) = sequence_ v + toList (SplitVector v) = toList v + elem x (SplitVector v) = elem x v + length (SplitVector v) = length v + null (SplitVector v) = null v + +instance Traversable (SplitVector n) where + traverse f (SplitVector v) = SplitVector <$> traverse f v + sequenceA (SplitVector v) = SplitVector <$> sequenceA v + mapM f (SplitVector v) = SplitVector <$> mapM f v + sequence (SplitVector v) = SplitVector <$> sequence v + +instance PrimSelectable (SplitVector n a) a where + primSelectFn pos (SplitVector v) = primSelectFn pos v + +instance PrimUpdateable (SplitVector n a) a where + primUpdateFn pos (SplitVector v) x n = SplitVector (primUpdateFn pos v x n) + +instance (FShow (Vector n a)) => FShow (SplitVector n a) where + fshow (SplitVector v) = fshow v + +instance (SplitPorts a p, ConcatTuple n p q) => SplitPorts (SplitVector n a) q where + splitPorts (SplitVector v) = concatTuple $ map splitPorts v + unsplitPorts = SplitVector ∘ map unsplitPorts ∘ unconcatTuple + portNames _ base = + let genElem i = portNames (_ :: a) (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 eaa521792..5b2d42b44 100644 --- a/src/Libraries/Base1/depends.mk +++ b/src/Libraries/Base1/depends.mk @@ -39,6 +39,7 @@ $(BUILDDIR)/Reserved.bo: Reserved.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeB $(BUILDDIR)/RevertingVirtualReg.bo: RevertingVirtualReg.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/SShow.bo: SShow.bs $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/SplitPorts.bo: SplitPorts.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo +$(BUILDDIR)/SplitVector.bo: SplitVector.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/CShow.bo $(BUILDDIR)/Foldable.bo $(BUILDDIR)/Traversable.bo $(BUILDDIR)/Traversable.bo: Traversable.bs $(BUILDDIR)/List.bo $(BUILDDIR)/ListN.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Foldable.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/TreeMap.bo: TreeMap.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo $(BUILDDIR)/Vector.bo: Vector.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Array.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo diff --git a/testsuite/bsc.verilog/splitports/SplitVectorOps.bs b/testsuite/bsc.verilog/splitports/SplitVectorOps.bs new file mode 100644 index 000000000..95197f3b3 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SplitVectorOps.bs @@ -0,0 +1,76 @@ +package SplitVectorOps where + +-- Tests for the non-port instances of the SplitVector newtype: Functor, +-- Applicative, Foldable, Traversable, Bounded, Eq, Bits, PrimSelectable, +-- PrimUpdateable and FShow. These all delegate to the underlying Vector, so we +-- just confirm the delegation works through the newtype wrapper. (Vector has +-- no Ord instance, so the derived Ord on SplitVector is not exercised.) + +import BuildVector +import SplitVector +import qualified Foldable +import qualified Traversable + +incMaybe :: Int 8 -> Maybe (Int 8) +incMaybe x = Valid (x + 1) + +a :: SplitVector 4 (Int 8) +a = SplitVector (vec 1 2 3 4) + +b :: SplitVector 4 (Int 8) +b = SplitVector (vec 10 20 30 40) + +-- Classic has no [] subscript syntax, so we drive PrimSelectable/PrimUpdateable +-- through the underlying class methods (this is how Vector's select/update are +-- defined, and how the BSV [] / [] := syntax desugars). +sel :: SplitVector 4 (Int 8) -> Integer -> Int 8 +sel sv i = primSelectFn (getStringPosition "") sv i + +{-# synthesize sysSplitVectorOps #-} +sysSplitVectorOps :: Module Empty +sysSplitVectorOps = + module + reg_sv :: Reg (SplitVector 4 (Int 8)) <- mkReg (SplitVector (vec 1 2 3 4)) + step :: Reg (UInt 2) <- mkReg 0 + + let lo :: SplitVector 4 (Int 8) + lo = minBound + hi :: SplitVector 4 (Int 8) + hi = maxBound + rt :: SplitVector 4 (Int 8) + rt = unpack (pack b) + + rules + -- Step 0: exercise the pure instances and issue a sub-element register + -- update (PrimUpdateable) whose effect we observe in step 1. + when step == 0 ==> do + -- Functor + $display "fmap: " (fshow (fmap (\ x -> x * 2) a)) + -- Applicative (only liftA2; SplitVector has pure, but it adds no extra + -- coverage of the delegation) + $display "liftA2: " (fshow (liftA2 (+) a b)) + -- Foldable + $display "foldr: %0d" (Foldable.foldr (+) 0 a) + $display "foldl: %0d" (Foldable.foldl (-) 0 a) + $display "length: %0d" (Foldable.length a) + $display "elem: " (fshow (Foldable.elem 3 a)) " " (fshow (Foldable.elem 99 a)) + -- Traversable (pure, via the Maybe applicative) + $display "trav: " (fshow (Traversable.traverse incMaybe a)) + -- Bounded + $display "bounds: " (fshow lo) " " (fshow hi) + -- Eq (Vector, and hence SplitVector, has no Ord instance) + $display "eq: " (fshow (a == a)) " " (fshow (a == b)) + -- Bits round-trip + $display "bits: " (fshow (rt == b)) + -- PrimSelectable + $display "select: %0d %0d" (sel a 0) (sel a 3) + -- FShow + $display "fshow: " (fshow a) + -- PrimUpdateable: update one element; observed next cycle. + reg_sv := primUpdateFn (getStringPosition "") reg_sv._read 1 99 + step := 1 + + -- Step 1: the register update is now visible. + when step == 1 ==> do + $display "reg: " (fshow reg_sv._read) " upd1 %0d" (sel reg_sv._read 1) + $finish diff --git a/testsuite/bsc.verilog/splitports/SplitVectorPorts.bs b/testsuite/bsc.verilog/splitports/SplitVectorPorts.bs new file mode 100644 index 000000000..911b8e39a --- /dev/null +++ b/testsuite/bsc.verilog/splitports/SplitVectorPorts.bs @@ -0,0 +1,162 @@ +package SplitVectorPorts where + +-- Tests for the SplitVector port-splitting newtype. +-- +-- SplitVector n a splits a vector into n groups of ports, splitting each +-- element via the element type's own SplitPorts instance. This exercises both +-- input and output port splitting: +-- * plain (default, whole-element) elements +-- * DeepSplit elements +-- * ShallowSplit elements +-- * a user-supplied SplitPorts instance as the element +-- * nested SplitVectors +-- * multiple split-vector arguments with an arg_names pragma +-- * a prefix pragma +-- * a SplitVector field of a shallow-split struct +-- * value methods, combinational methods (split input + split output) and +-- ActionValue methods that return SplitVectors (output port splitting) +-- +-- The values are recovered for display (verifying the splitPorts/unsplitPorts +-- round-trip through the generated ports) using the unShallowSplit / unDeepSplit +-- helpers from the SplitPorts library and unSplitVector from the SplitVector +-- library. + +import Vector +import BuildVector +import SplitPorts +import SplitVector +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) + +-- A custom (non-tag) SplitPorts instance, to check that SplitVector defers to +-- the element type's own SplitPorts instance for naming and splitting. +struct Pair = + a :: Int 8 + b :: UInt 16 + deriving (Bits) + +instance SplitPorts Pair (Port (Int 8), Port (UInt 16)) where + splitPorts x = (Port x.a, Port x.b) + unsplitPorts (Port a, Port b) = Pair { a = a; b = b; } + portNames _ base = Cons (base +++ "_a") $ Cons (base +++ "_b") Nil + +-- A struct with a SplitVector field, to check that SplitVector composes inside +-- a shallow-split struct. +struct Wrap = + items :: SplitVector 2 (DeepSplit Foo) + tag :: Bool + -- No Bits instance needed + +interface SplitTest = + -- == Input port splitting == + -- Plain elements: each element kept whole as one port (default SplitPorts). + putInts :: SplitVector 4 (Int 8) -> Action + -- DeepSplit elements: each Foo recursively split into x and y ports. + putFoos :: SplitVector 3 (DeepSplit Foo) -> Action + -- ShallowSplit elements, with a prefix pragma. + putBars :: SplitVector 2 (ShallowSplit Bar) -> Action {-# prefix = "PUT_BARS" #-} + -- Custom SplitPorts instance elements. + putPairs :: SplitVector 2 Pair -> Action + -- Nested SplitVectors. + putGrid :: SplitVector 2 (SplitVector 3 (DeepSplit Foo)) -> Action + -- Multiple split-vector arguments with arg_names. + putTwo :: SplitVector 2 (DeepSplit Foo) -> SplitVector 2 (Int 8) -> Action {-# arg_names = ["foos", "ints"] #-} + -- SplitVector as a field of a shallow-split struct. + putWrap :: ShallowSplit Wrap -> Action + + -- == Output port splitting == + -- Value method, plain elements: output ports getInts_0 .. getInts_3. + getInts :: SplitVector 4 (Int 8) + -- Value method, DeepSplit elements, with a result pragma naming the outputs. + getFoos :: SplitVector 3 (DeepSplit Foo) {-# result = "GET_FOOS" #-} + -- Combinational method: split input AND split output (the in -> out path is + -- checked in the generated Verilog). + bumpFoos :: SplitVector 2 (DeepSplit Foo) -> SplitVector 2 (DeepSplit Foo) {-# result = "BUMP" #-} + -- ActionValue method: split input and split output. + updateVec :: SplitVector 2 (Int 8) -> ActionValue (SplitVector 2 (DeepSplit Foo)) + +{-# synthesize mkSplitVectorPortsTest #-} +mkSplitVectorPortsTest :: Module SplitTest +mkSplitVectorPortsTest = + module + acc :: Reg (Int 8) <- mkReg 0 + interface + putInts sv = $display "putInts: " (cshow (unSplitVector sv)) + putFoos sv = $display "putFoos: " (cshow (map unDeepSplit (unSplitVector sv))) + putBars sv = $display "putBars: " (cshow (map unShallowSplit (unSplitVector sv))) + putPairs sv = $display "putPairs: " (cshow (unSplitVector sv)) + putGrid sv = $display "putGrid: " (cshow (map (\ inner -> map unDeepSplit (unSplitVector inner)) (unSplitVector sv))) + putTwo foos ints = $display "putTwo: " (cshow (map unDeepSplit (unSplitVector foos))) " " (cshow (unSplitVector ints)) + putWrap (ShallowSplit w) = + $display "putWrap: items=" (cshow (map unDeepSplit (unSplitVector w.items))) " tag=" (cshow w.tag) + + getInts = SplitVector (vec 50 60 70 80) + getFoos = SplitVector $ map DeepSplit $ + vec (Foo { x = 1; y = 2; }) (Foo { x = 3; y = 4; }) (Foo { x = 5; y = 6; }) + bumpFoos sv = + SplitVector $ map (\ f -> DeepSplit $ Foo { x = f.x + 1; y = f.y - 1; }) $ + map unDeepSplit (unSplitVector sv) + updateVec sv = do + acc := acc + 1 + return $ SplitVector $ map (\ n -> DeepSplit $ Foo { x = n; y = acc; }) (unSplitVector sv) + +{-# synthesize sysSplitVectorPorts #-} +sysSplitVectorPorts :: Module Empty +sysSplitVectorPorts = + module + s <- mkSplitVectorPortsTest + i :: Reg (UInt 8) <- mkReg 0 + rules + when True ==> i := i + 1 + when i == 0 ==> + s.putInts $ SplitVector $ vec 10 (negate 20) 30 (negate 40) + when i == 1 ==> + s.putFoos $ SplitVector $ map DeepSplit $ + vec (Foo { x = 1; y = 2; }) (Foo { x = 3; y = 4; }) (Foo { x = 5; y = 6; }) + when i == 2 ==> + s.putBars $ SplitVector $ map ShallowSplit $ + vec (Bar { v = vec True False True; w = (True, 0x1234); z = Foo { x = 7; y = 8; } }) + (Bar { v = vec False True False; w = (False, 0x5678); z = Foo { x = 9; y = 10; } }) + when i == 3 ==> + s.putPairs $ SplitVector $ + vec (Pair { a = 11; b = 0xABCD; }) (Pair { a = negate 12; b = 0x00FF; }) + when i == 4 ==> + s.putGrid $ SplitVector $ + vec (SplitVector $ map DeepSplit $ + vec (Foo { x = 1; y = 2; }) (Foo { x = 3; y = 4; }) (Foo { x = 5; y = 6; })) + (SplitVector $ map DeepSplit $ + vec (Foo { x = 7; y = 8; }) (Foo { x = 9; y = 10; }) (Foo { x = 11; y = 12; })) + when i == 5 ==> + s.putTwo (SplitVector $ map DeepSplit $ vec (Foo { x = 13; y = 14; }) (Foo { x = 15; y = 16; })) + (SplitVector $ vec 100 (negate 101)) + when i == 6 ==> + s.putWrap $ ShallowSplit $ + Wrap { items = SplitVector $ map DeepSplit $ + vec (Foo { x = 21; y = 22; }) (Foo { x = 23; y = 24; }); + tag = True; } + when i == 7 ==> + $display "getInts: " (cshow (unSplitVector s.getInts)) + when i == 8 ==> + $display "getFoos: " (cshow (map unDeepSplit (unSplitVector s.getFoos))) + when i == 9 ==> + $display "bumpFoos: " + (cshow (map unDeepSplit (unSplitVector + (s.bumpFoos (SplitVector $ map DeepSplit $ + vec (Foo { x = 30; y = 40; }) (Foo { x = 50; y = 60; })))))) + when i == 10 ==> do + res <- s.updateVec (SplitVector $ vec 70 80) + $display "updateVec: " (cshow (map unDeepSplit (unSplitVector res))) + when i == 11 ==> do + res <- s.updateVec (SplitVector $ vec 90 100) + $display "updateVec: " (cshow (map unDeepSplit (unSplitVector res))) + when i == 12 ==> $finish diff --git a/testsuite/bsc.verilog/splitports/splitports.exp b/testsuite/bsc.verilog/splitports/splitports.exp index 94997b4c4..d3b772805 100644 --- a/testsuite/bsc.verilog/splitports/splitports.exp +++ b/testsuite/bsc.verilog/splitports/splitports.exp @@ -221,6 +221,57 @@ if { $vtest == 1 } { find_regexp_fail sysSplitTupleSensitivity.v {or pick__f1[ )]} } +# SplitVector: splits a vector into n groups of ports, splitting each element +# via the element type's own SplitPorts instance, for both inputs and outputs. +test_c_veri SplitVectorPorts +if { $vtest == 1 } { + # -- input port splitting -- + # plain elements: each kept whole as one port + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putInts_1_0;} + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putInts_1_3;} + # DeepSplit elements: each Foo recursively split into x and y + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putFoos_1_0_x;} + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putFoos_1_2_y;} + # ShallowSplit elements, with a prefix pragma + find_regexp mkSplitVectorPortsTest.v {input \[2 : 0\] PUT_BARS_1_0_v;} + find_regexp mkSplitVectorPortsTest.v {input \[16 : 0\] PUT_BARS_1_1_w;} + find_regexp mkSplitVectorPortsTest.v {input \[15 : 0\] PUT_BARS_1_1_z;} + # custom (non-tag) SplitPorts instance elements + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putPairs_1_0_a;} + find_regexp mkSplitVectorPortsTest.v {input \[15 : 0\] putPairs_1_1_b;} + # nested SplitVectors + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putGrid_1_0_0_x;} + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putGrid_1_1_2_y;} + # multiple split-vector arguments with an arg_names pragma + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putTwo_foos_0_x;} + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putTwo_ints_1;} + # a SplitVector field of a shallow-split struct + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] putWrap_1_items_0_x;} + find_regexp mkSplitVectorPortsTest.v {input putWrap_1_tag;} + # -- output port splitting -- + # value method, plain elements + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] getInts_0;} + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] getInts_3;} + # value method, DeepSplit elements, with a result pragma + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] GET_FOOS_0_x;} + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] GET_FOOS_2_y;} + # combinational method: split input and split output (result pragma) + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] bumpFoos_1_0_x;} + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] BUMP_0_x;} + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] BUMP_1_y;} + # the split input element feeds the split output element combinationally + find_regexp mkSplitVectorPortsTest.v {bumpFoos_1_0_x -> BUMP_0_x} + # ActionValue method: split input and split output + find_regexp mkSplitVectorPortsTest.v {input \[7 : 0\] updateVec_1_0;} + find_regexp mkSplitVectorPortsTest.v {input EN_updateVec;} + find_regexp mkSplitVectorPortsTest.v {output \[7 : 0\] updateVec_0_x;} + find_regexp mkSplitVectorPortsTest.v {output RDY_updateVec;} +} + +# SplitVector also delegates the standard Vector instances (Functor, Applicative, +# Foldable, Traversable, Bounded, Eq, Bits, PrimSelectable, PrimUpdateable, FShow). +test_c_veri SplitVectorOps + # ---------- compile_verilog_fail_error TooManyArgNames.bs S0015 diff --git a/testsuite/bsc.verilog/splitports/sysSplitVectorOps.out.expected b/testsuite/bsc.verilog/splitports/sysSplitVectorOps.out.expected new file mode 100644 index 000000000..feb5ee538 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSplitVectorOps.out.expected @@ -0,0 +1,13 @@ +fmap: +liftA2: +foldr: 10 +foldl: -10 +length: 4 +elem: True False +trav: tagged Valid +bounds: +eq: True False +bits: True +select: 1 4 +fshow: +reg: upd1 99 diff --git a/testsuite/bsc.verilog/splitports/sysSplitVectorPorts.out.expected b/testsuite/bsc.verilog/splitports/sysSplitVectorPorts.out.expected new file mode 100644 index 000000000..70be247b6 --- /dev/null +++ b/testsuite/bsc.verilog/splitports/sysSplitVectorPorts.out.expected @@ -0,0 +1,12 @@ +putInts: [ 10, -20, 30, -40] +putFoos: [Foo {x= 1; y= 2}, Foo {x= 3; y= 4}, Foo {x= 5; y= 6}] +putBars: [Bar {v=[True, False, True]; w=(True, 4660); z=Foo {x= 7; y= 8}}, Bar {v=[False, True, False]; w=(False, 22136); z=Foo {x= 9; y= 10}}] +putPairs: [Pair {a= 11; b=43981}, Pair {a= -12; b= 255}] +putGrid: [[Foo {x= 1; y= 2}, Foo {x= 3; y= 4}, Foo {x= 5; y= 6}], [Foo {x= 7; y= 8}, Foo {x= 9; y= 10}, Foo {x= 11; y= 12}]] +putTwo: [Foo {x= 13; y= 14}, Foo {x= 15; y= 16}] [ 100, -101] +putWrap: items=[Foo {x= 21; y= 22}, Foo {x= 23; y= 24}] tag=True +getInts: [ 50, 60, 70, 80] +getFoos: [Foo {x= 1; y= 2}, Foo {x= 3; y= 4}, Foo {x= 5; y= 6}] +bumpFoos: [Foo {x= 31; y= 39}, Foo {x= 51; y= 59}] +updateVec: [Foo {x= 70; y= 0}, Foo {x= 80; y= 0}] +updateVec: [Foo {x= 90; y= 1}, Foo {x= 100; y= 1}] From 5c5ebb12ceeb942150770aec542eea72179f534c Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 19:08:45 -0700 Subject: [PATCH 03/18] Detect coherent matches that depend on incoherent ones This is a squash merge of GitHub PR 923. Store root-cause and class info in SolvedBinds for incoherence diagnostics. Diagnose transitive incoherence (T0158 warn vs error) based on class annotation and -incoherent-instance-matches flag. Test cases (with flag on and off) added. --- src/comp/CSyntaxUtil.hs | 4 + src/comp/CType.hs | 10 +- src/comp/Error.hs | 7 + src/comp/GenABin.hs | 2 +- src/comp/GenBin.hs | 2 +- src/comp/Id.hs | 2 +- src/comp/Simplify.hs | 5 +- src/comp/SolvedBinds.hs | 131 +++++++++++++++--- src/comp/TCMisc.hs | 54 +++++++- src/comp/TCheck.hs | 10 +- src/comp/TypeCheck.hs | 3 +- .../typeclasses/coherence/IncoherentBase.bs | 17 +++ .../coherence/Instance_Coherent.bs | 40 ++++++ .../typeclasses/coherence/Instance_Default.bs | 37 +++++ .../coherence/Instance_Incoherent.bs | 37 +++++ .../typeclasses/coherence/Makefile | 5 + .../typeclasses/coherence/Super_Coherent.bs | 37 +++++ .../typeclasses/coherence/Super_Default.bs | 37 +++++ .../typeclasses/coherence/Super_Incoherent.bs | 37 +++++ .../typeclasses/coherence/coherence.exp | 50 +++++++ .../sysInstance_Coherent.out.expected | 3 + .../sysInstance_Default.out.expected | 3 + .../sysInstance_Incoherent.out.expected | 3 + .../coherence/sysSuper_Coherent.out.expected | 3 + .../coherence/sysSuper_Default.out.expected | 3 + .../sysSuper_Incoherent.out.expected | 3 + 26 files changed, 508 insertions(+), 37 deletions(-) create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/IncoherentBase.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Instance_Coherent.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Instance_Default.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Instance_Incoherent.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Makefile create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Super_Coherent.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Super_Default.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/Super_Incoherent.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/coherence.exp create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Coherent.out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Default.out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Incoherent.out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Coherent.out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Default.out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Incoherent.out.expected diff --git a/src/comp/CSyntaxUtil.hs b/src/comp/CSyntaxUtil.hs index 8272d64c4..d0dda12d8 100644 --- a/src/comp/CSyntaxUtil.hs +++ b/src/comp/CSyntaxUtil.hs @@ -59,6 +59,10 @@ pMkEitherTree pos i n e where leftSize = (n + 1) `div` 2 rightSize = n `div` 2 +isCPVar :: CPat -> Bool +isCPVar (CPVar _) = True +isCPVar _ = False + mkMaybe :: (Maybe CExpr) -> CExpr mkMaybe Nothing = CCon idInvalid [] mkMaybe (Just e) = CCon idValid [e] diff --git a/src/comp/CType.hs b/src/comp/CType.hs index 657fad091..39e045be8 100644 --- a/src/comp/CType.hs +++ b/src/comp/CType.hs @@ -9,7 +9,7 @@ module CType( getTyVarId, getTypeKind, isTNum, getTNum, isTStr, getTStr, - isTVar, isTCon, isIfc, isInterface, isUpdateable, + isTVar, isTCon, isIfc, isInterface, isDictType, isDictFun, isUpdateable, leftCon, leftTyCon, allTyCons, allTConNames, tyConArgs, splitTAp, normTAp, isATFAp, @@ -399,6 +399,14 @@ isInterface :: CType -> Bool isInterface t | Just (TyCon _ _ (TIstruct s _)) <- leftTyCon t = isIfc s isInterface _ = False +isDictType :: CType -> Bool +isDictType t | Just (TyCon _ _ (TIstruct SClass _)) <- leftTyCon t = True +isDictType _ = False + +isDictFun :: CType -> Bool +isDictFun t = all isDictType (res:args) + where (args, res) = getArrows t + isUpdateable :: StructSubType -> Bool isUpdateable SStruct = True isUpdateable SInterface {} = True diff --git a/src/comp/Error.hs b/src/comp/Error.hs index 7862bd256..424bdde54 100644 --- a/src/comp/Error.hs +++ b/src/comp/Error.hs @@ -797,6 +797,7 @@ data ErrMsg = | EClassFundepsEmpty String | WIncoherentMatch String String | WOrphanInst String + | WTransitiveIncoherentMatch String String String | EModInstWrongArgs [Position] | EAmbiguous [(String, Position, [(String, [Position])])] | EAmbiguousExplCtx [Doc] [Doc] Doc @@ -3008,6 +3009,12 @@ getErrorText (WUnusedImport pkg) = (Type 157, empty, s2par ("Package " ++ ishow pkg ++ " is imported but not used")) +getErrorText (WTransitiveIncoherentMatch pred root_pred root_inst) = + (Type 158, empty, + s2par ("Proviso " ++ pred ++ " is satisfied by a dictionary that transitively " ++ + "depends on an incoherent match of " ++ root_pred ++ + " against instance " ++ root_inst)) + -- Generation Errors getErrorText (EGenerate num s) = diff --git a/src/comp/GenABin.hs b/src/comp/GenABin.hs index 1a075f2b2..3e15ddd1a 100644 --- a/src/comp/GenABin.hs +++ b/src/comp/GenABin.hs @@ -34,7 +34,7 @@ import qualified Data.ByteString as B -- .ba file tag -- change this whenever the .ba format changes -- See also GenBin.header header :: [Byte] -header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260618-1" +header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260705-1" genABinFile :: ErrorHandle -> String -> ABin -> IO () genABinFile errh fn abin = diff --git a/src/comp/GenBin.hs b/src/comp/GenBin.hs index f2fc430e9..b2b0806f4 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-20260616-1" +header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20260705-1" genBinFile :: ErrorHandle -> String -> CSignature -> CSignature -> IPackage a -> IO () diff --git a/src/comp/Id.hs b/src/comp/Id.hs index affdd0c47..af00795ac 100644 --- a/src/comp/Id.hs +++ b/src/comp/Id.hs @@ -161,7 +161,7 @@ data IdProp = IdPCanFire -- used by the BSV parser to keep track of which array types -- were introduced from bracket syntax | IdPParserGenerated - | IdPIncoherent -- Used to track incoherent instance matches for future use + | IdPIncoherent -- Used to track incoherent instance matches deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable) -- ############################################################################# diff --git a/src/comp/Simplify.hs b/src/comp/Simplify.hs index 7ab265df9..98d21d649 100644 --- a/src/comp/Simplify.hs +++ b/src/comp/Simplify.hs @@ -9,6 +9,7 @@ import ErrorUtil(internalError) import Id(Id, isKeepId, isDictId) import CSyntax hiding(cLetRec) import CSyntaxTypes() +import CSyntaxUtil(isCPVar) import CFreeVars(getFVE, getPV, getFVD) import Subst import CType(getCQArrows) @@ -325,10 +326,6 @@ selectSimpleL r lds = -- ppReadable (map (flip CLValueSign []) ds) ++ -- "\nwithquals:\n" ++ ppReadable [ ld | ld@(CLValueSign _ (_ : _)) <- lds ] ++ "\n") $ -isCPVar :: CPat -> Bool -isCPVar (CPVar _) = True -isCPVar _ = False - -- collect variables captured in a let arm -- different from *bound* variables, e.g., consider: -- let f x y = ... in ... diff --git a/src/comp/SolvedBinds.hs b/src/comp/SolvedBinds.hs index 481ae69a0..e2e7636db 100644 --- a/src/comp/SolvedBinds.hs +++ b/src/comp/SolvedBinds.hs @@ -3,14 +3,20 @@ -- no references to recursive bindings from non-recursive bindings and keep non-recursive -- bindings in topologically sorted order. module SolvedBinds(SolvedBind, mkSolvedBind, SolvedBinds, Bind, - markIncoherent, + markIncoherent, isIncoherent, solvedClass, + DirectIncoherence(..), addDirectIncoherence, sbsEmpty, fromSB, (<++), emptySBs, - getRecursiveDefls, getNonRecursiveDefls) where + recursiveBinds, nonRecursiveBinds, + bindClasses, bindTypes, directIncoherences, + getRecursiveDefls, getNonRecursiveDefls, + getIncoherentIds, computeTransitiveIncoherent) where import Prelude hiding ((<>)) import Data.List(union, partition) +import Data.Maybe(listToMaybe) import qualified Data.Set as S +import qualified Data.Map.Strict as M import ErrorUtil(internalError) import Id @@ -18,6 +24,8 @@ import CSyntax import CSyntaxTypes() import CFreeVars(getFVE) import PPrint +import Position +import Pred(Class, Pred) import Subst -- Dictionary binding representation @@ -27,26 +35,37 @@ type Bind = (Id, Type, CExpr) mkDefl :: Bind -> CDefl mkDefl (i, t, e) = CLValueSign (CDefT i [] (CQType [] t) [CClause [] [] e]) [] +-- Root cause of a direct incoherent match, for use in transitive-incoherence warnings. +data DirectIncoherence = DirectIncoherence { + diPred :: Pred, -- the pred being satisfied (after final substitution) + diInst :: Pred, -- the incoherent instance head (after final substitution) + diPos :: Position -- position where the direct match occurred +} deriving (Show) + data SolvedBind = SolvedBind { bind :: Bind, freeVars :: S.Set Id, - isRecursive :: Bool + isRecursive :: Bool, + isIncoherent :: Bool, + solvedClass :: Maybe Class -- the class this bind resolves (for allowIncoherent check) } deriving (Show) instance PPrint SolvedBind where - pPrint d p (SolvedBind bind fv isRec) = + pPrint d p (SolvedBind bind fv isRec isInc _) = text "SolvedBind" <+> braces ( text "bind:" <+> pPrint d p bind <> semi <+> text "freeVars:" <+> pPrint d p fv <> semi <+> - text "isRecursive:" <+> pPrint d p isRec + text "isRecursive:" <+> pPrint d p isRec <> semi <+> + text "isIncoherent:" <+> pPrint d p isInc ) mkSolvedBind :: Bind -> Bool -> SolvedBind mkSolvedBind b@(_,_,e) isRec = - SolvedBind { bind = b, freeVars = snd (getFVE e), isRecursive = isRec } + SolvedBind { bind = b, freeVars = snd (getFVE e), isRecursive = isRec, + isIncoherent = False, solvedClass = Nothing } markIncoherent :: SolvedBind -> SolvedBind -markIncoherent sb = sb { bind = mark (bind sb) } +markIncoherent sb = sb { bind = mark (bind sb), isIncoherent = True } where mark (i, t, e) = (addIdProp i IdPIncoherent, t, e) -- Collection of bindings categorized by recursion @@ -55,38 +74,51 @@ data SolvedBinds = SolvedBinds { recursiveBinds :: [(Bind, S.Set Id)], -- binding and free variables nonRecursiveBinds :: [(Bind, S.Set Id)], recursiveIds :: S.Set Id, - nonRecursiveIds :: S.Set Id + nonRecursiveIds :: S.Set Id, + incoherentIds :: S.Set Id, + bindClasses :: M.Map Id Class, -- class per bind (for allowIncoherent check) + bindTypes :: M.Map Id Type, -- type per bind (for diagnostic messages) + directIncoherences :: M.Map Id DirectIncoherence -- root cause per directly-incoherent bind } deriving (Show) instance Types SolvedBinds where apSub s sbs = sbs { recursiveBinds = [ ((i, apSub s t, apSub s e), fv) | ((i, t, e), fv) <- recursiveBinds sbs ], - nonRecursiveBinds = [ ((i, apSub s t, apSub s e), fv) | ((i, t, e), fv) <- nonRecursiveBinds sbs ] + nonRecursiveBinds = [ ((i, apSub s t, apSub s e), fv) | ((i, t, e), fv) <- nonRecursiveBinds sbs ], + bindTypes = M.map (apSub s) (bindTypes sbs) } tv sbs = recTVs `union` nonRecTVs where recTVs = tv [ (t, e) | ((_, t, e), _) <- recursiveBinds sbs ] nonRecTVs = tv [ (t, e) | ((_, t, e), _) <- nonRecursiveBinds sbs ] sbsEmpty :: SolvedBinds -> Bool -sbsEmpty (SolvedBinds recs nonrecs _ _) = null recs && null nonrecs +sbsEmpty sbs = null (recursiveBinds sbs) && null (nonRecursiveBinds sbs) -- Create singleton SolvedBinds from SolvedBind -- Note: Both self-recursive and non-recursive bindings are independent of accum -- Self-recursive bindings depend only on themselves, fresh variables, and source EPreds fromSB :: SolvedBind -> SolvedBinds -fromSB (SolvedBind b@(i, _, _) fv isRec) = +fromSB (SolvedBind b@(i, t, _) fv isRec isInc cls) = if isRec then SolvedBinds { recursiveBinds = [(b, fv)], nonRecursiveBinds = [], recursiveIds = S.singleton i, - nonRecursiveIds = S.empty + nonRecursiveIds = S.empty, + incoherentIds = if isInc then S.singleton i else S.empty, + bindClasses = maybe M.empty (M.singleton i) cls, + bindTypes = M.singleton i t, + directIncoherences = M.empty } else SolvedBinds { recursiveBinds = [], nonRecursiveBinds = [(b, fv)], recursiveIds = S.empty, - nonRecursiveIds = S.singleton i + nonRecursiveIds = S.singleton i, + incoherentIds = if isInc then S.singleton i else S.empty, + bindClasses = maybe M.empty (M.singleton i) cls, + bindTypes = M.singleton i t, + directIncoherences = M.empty } infixl 6 <++ -- directional append new <++ old @@ -120,27 +152,88 @@ new <++ old recursiveBinds = newlyRec ++ recursiveBinds new ++ recursiveBinds old, nonRecursiveBinds = nonRecursiveBinds new ++ stillNonRec, recursiveIds = newRecIds `S.union` recursiveIds old, - nonRecursiveIds = nonRecursiveIds new `S.union` (nonRecursiveIds old `S.difference` nowNotNonRecIds) + nonRecursiveIds = nonRecursiveIds new `S.union` (nonRecursiveIds old `S.difference` nowNotNonRecIds), + incoherentIds = incoherentIds new `S.union` incoherentIds old, + bindClasses = bindClasses new `M.union` bindClasses old, + bindTypes = bindTypes new `M.union` bindTypes old, + directIncoherences = directIncoherences new `M.union` directIncoherences old } noBadDeps = all (not . dependsOn (recursiveIds result)) (nonRecursiveBinds result) +-- Compute the transitive closure of incoherence across all bindings: any +-- binding whose free variables reference an incoherent Id is itself incoherent. +-- Works across both recursive and non-recursive bindings simultaneously. +-- Marks newly-incoherent binding Ids with IdPIncoherent and updates incoherentIds. +-- Also propagates DirectIncoherence root-cause info through the closure. +-- Call this once on a fully-merged SolvedBinds before consuming it. +computeTransitiveIncoherent :: SolvedBinds -> SolvedBinds +computeTransitiveIncoherent sbs = sbs { + recursiveBinds = map markBind (recursiveBinds sbs), + nonRecursiveBinds = map markBind (nonRecursiveBinds sbs), + incoherentIds = finalIds, + directIncoherences = propagatedSources + } + where + direct = incoherentIds sbs + allBindings = recursiveBinds sbs ++ nonRecursiveBinds sbs + finalIds = go direct + go known + | S.null newIds = known + | otherwise = go (known `S.union` newIds) + where newIds = S.fromList [ i | ((i, _, _), fv) <- allBindings + , not (S.member i known) + , not (S.disjoint fv known) ] + markBind b@((i, t, e), fv) + | S.member i finalIds && not (S.member i direct) = + ((addIdProp i IdPIncoherent, t, e), fv) + | otherwise = b + -- Propagate root-cause DirectIncoherence through the transitive closure: + -- for each newly-transitively-incoherent bind, inherit the source from + -- the first free var that already has a known source. + propagateSources known + | M.null newEntries = known + | otherwise = propagateSources (M.union known newEntries) + where + newEntries = M.fromList + [ (i, src) + | ((i, _, _), fv) <- allBindings + , S.member i finalIds + , not (M.member i known) + , Just src <- [listToMaybe [s | j <- S.toList fv + , Just s <- [M.lookup j known]]] + ] + propagatedSources = propagateSources (directIncoherences sbs) + +-- Record the root cause of a direct incoherent match for the given dict Id. +-- Called from sat after niceTypes provides the pretty-printed pred/inst strings. +addDirectIncoherence :: Id -> DirectIncoherence -> SolvedBinds -> SolvedBinds +addDirectIncoherence i di sbs = + sbs { directIncoherences = M.insert i di (directIncoherences sbs) } + emptySBs :: SolvedBinds emptySBs = SolvedBinds { recursiveBinds = [], nonRecursiveBinds = [], recursiveIds = S.empty, - nonRecursiveIds = S.empty + nonRecursiveIds = S.empty, + incoherentIds = S.empty, + bindClasses = M.empty, + bindTypes = M.empty, + directIncoherences = M.empty } instance PPrint SolvedBinds where - pPrint d p (SolvedBinds recs nonrecs _ _) = + pPrint d p sbs = text "SolvedBinds" <+> braces ( - text "rec:" <+> pPrint d p recs <> semi <+> - text "nonRec:" <+> pPrint d p nonrecs + text "rec:" <+> pPrint d p (recursiveBinds sbs) <> semi <+> + text "nonRec:" <+> pPrint d p (nonRecursiveBinds sbs) ) getRecursiveDefls :: SolvedBinds -> [CDefl] getRecursiveDefls = map (mkDefl . fst) . recursiveBinds getNonRecursiveDefls :: SolvedBinds -> [CDefl] -getNonRecursiveDefls = map (mkDefl .fst) . nonRecursiveBinds +getNonRecursiveDefls = map (mkDefl . fst) . nonRecursiveBinds + +getIncoherentIds :: SolvedBinds -> S.Set Id +getIncoherentIds = incoherentIds diff --git a/src/comp/TCMisc.hs b/src/comp/TCMisc.hs index 9436ce7b6..9ddf11f23 100644 --- a/src/comp/TCMisc.hs +++ b/src/comp/TCMisc.hs @@ -9,7 +9,8 @@ module TCMisc( mkVPred, mkVPredNoNewPos, mkVPredFromPred, toPredWithPositions, toPred, defaultClasses, checkForAmbiguousPreds, - propagateFunDeps, isReduciblePred + propagateFunDeps, isReduciblePred, + warnTransitiveIncoherent ) where import Data.Maybe @@ -39,7 +40,7 @@ import TIMonad import PreIds import StdPrel(isPreClass, mkNumInstBody) import CSyntax(CExpr(..), CPat(..), CQual(..), CLiteral(..), - cTApply, cVApply, anyTExpr) + cTApply, cVApply) import Literal import IntLit import SymTab @@ -217,6 +218,39 @@ mkATFClassPred tag posType clsId pIdxs tIdx atfArgs targetType = do | idx <- [0..nParams-1] ] return (cls, classArgs) +-- Compute the transitive incoherence closure on a fully-merged SolvedBinds, +-- emitting a warning or error for each binding that becomes transitively incoherent. +-- Behaviour depends on the class annotation (allowIncoherent) of the depending bind: +-- incoherent (Just True) -- suppress: the class explicitly allows incoherence +-- coherent (Just False) -- error T0158: coherence promise violated +-- default (Nothing) -- error T0158 if -incoherent-instance-matches is off +-- -- warn T0158 if -incoherent-instance-matches is on +-- Uses the stored DirectIncoherence info for accurate position and root-cause message. +warnTransitiveIncoherent :: SolvedBinds -> TI SolvedBinds +warnTransitiveIncoherent sbs = do + let sbs' = computeTransitiveIncoherent sbs + newlyIncoherent = getIncoherentIds sbs' `S.difference` getIncoherentIds sbs + mapM_ (diagnoseOne (bindTypes sbs') (directIncoherences sbs') (bindClasses sbs')) + (S.toList newlyIncoherent) + return sbs' + where + diagnoseOne typeMap diMap clsMap i = do + ai <- getAllowIncoherent + case M.lookup i clsMap >>= allowIncoherent of + Just True -> return () -- incoherent class: suppress + mallow -> + let msg = (pos, WTransitiveIncoherentMatch tStr rootPredStr rootInstStr) + in if fromMaybe ai mallow then twarn msg else err msg + where + t = fromJustOrErr "warnTransitiveIncoherent: id not in bindTypes" + (M.lookup i typeMap) + di = fromJustOrErr "warnTransitiveIncoherent: id not in directIncoherences" + (M.lookup i diMap) + pos = diPos di + (rootPredStr, rootInstStr) = let (np, ni) = niceTypes (diPred di, diInst di) + in (pfpString np, pfpString ni) + tStr = pfpString t + -- expand all type functions expTFun :: Type -> TI ([VPred], Type) -- Type function application: try to generate a class constraint so @@ -361,9 +395,12 @@ sat dvs ps p = recordPackageUse mpkg let (vp_pred, inst_pred) = niceTypes (apSub s_final (toPred p, h)) let pos = getPosition $ getVPredPositions p + let VPred dictId _ = p + di = DirectIncoherence (apSub s_final (toPred p)) (apSub s_final h) pos + sbs' = addDirectIncoherence dictId di sbs when (allowIncoherent c /= Just True) $ twarn (pos, WIncoherentMatch (pfpString vp_pred) (pfpString inst_pred)) - return $ ([], sbs, s_final) + return $ ([], sbs', s_final) bad_match -> fail ("sat incoherent disallowed: " ++ ppReadable bad_match) decrementSatStack return return_val @@ -570,6 +607,10 @@ reducePred eps dvs (VPred w pp@(PredWithPositions pr@(IsIn c ts) pos)) = do case x of Nothing -> do let chk = predUnify bound_tyvars pr' h + -- If chk is true, we have found a more-specific instance that could + -- have matched if more type information were known, but didn't because + -- the instance being requested is more general. Any instance matches + -- from this point on are incoherent matches. f (chk || incoherent) is Just (qs, sb, (inst_subst, fd_subst), mpkg) -> do -- when ((not $ null qs) && (not $ isNullSubst inst_subst)) $ @@ -582,7 +623,12 @@ reducePred eps dvs (VPred w pp@(PredWithPositions pr@(IsIn c ts) pos)) = do ppReadable (v', i', m_tv, inst_subst, fd_subst, incoherent)) let Inst _ _ (_ :=> h) _ = i let minst = toMaybe incoherent h - return $ Just (qs, sb, fd_subst, minst, mpkg) + -- Mark the binding incoherent, so that warnTransitiveIncoherent + -- can identify bindings that transitively depend on it. + sb' = if incoherent then markIncoherent sb else sb + -- Record the class so warnTransitiveIncoherent can check allowIncoherent. + sb'' = sb' { solvedClass = Just c } + return $ Just (qs, sb'', fd_subst, minst, mpkg) let is' = genInsts c bound_tyvars dvs pr' r <- f False is' diff --git a/src/comp/TCheck.hs b/src/comp/TCheck.hs index f51434c84..ca4fd6488 100644 --- a/src/comp/TCheck.hs +++ b/src/comp/TCheck.hs @@ -2564,9 +2564,9 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do (rs_amb, rs_unamb) = partition (any (`elem` amb_vars) . tv) rs -- Apply the substitution to the code fragments - let alts'' = apSub s alts' -- new alternatives - asbs = apSub s sbs1 -- new dict bindings - me'' = apSub s me' -- update guards + let alts'' = apSub s alts' -- new alternatives + me'' = apSub s me' -- update guards + asbs <- warnTransitiveIncoherent (apSub s sbs1) -- new dict bindings -- Determine the generic variables and produce the inferred type scheme let @@ -2921,8 +2921,8 @@ tiImpls recursive as ibs = do -- update the info we computed above s <- getSubst - let sbs_final = apSub s (sbs3 <++ sbs2 <++ sbs1) - ts_final = apSub s ts' + sbs_final <- warnTransitiveIncoherent (apSub s (sbs3 <++ sbs2 <++ sbs1)) + let ts_final = apSub s ts' fs_final = tv (apSub s as) `union` bvs vss_final = map tv ts_final lvs_final = foldr1 union vss_final diff --git a/src/comp/TypeCheck.hs b/src/comp/TypeCheck.hs index 83d5a38e3..bc589051c 100644 --- a/src/comp/TypeCheck.hs +++ b/src/comp/TypeCheck.hs @@ -136,7 +136,8 @@ checkTopPreds mid a ps = do topExpr :: CType -> CExpr -> TI ([VPred], CExpr) topExpr td e = do (ps, e') <- tiExpr [] td e - (ps', sbs) <- satisfy [] ps + (ps', sbs0) <- satisfy [] ps + sbs <- warnTransitiveIncoherent sbs0 s <- getSubst let rec_defls = getRecursiveDefls sbs nonrec_defls = getNonRecursiveDefls sbs diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/IncoherentBase.bs b/testsuite/bsc.typechecker/typeclasses/coherence/IncoherentBase.bs new file mode 100644 index 000000000..c537069b8 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/IncoherentBase.bs @@ -0,0 +1,17 @@ +package IncoherentBase where + +import Vector +import Prelude + +type Byte = Bit 8 + +class incoherent IncoherentBase a where + baseMethod :: a -> String + +-- Generic vector instance +instance IncoherentBase (Vector n a) where + baseMethod _ = "generic vector instance" + +-- Specific byte vector instance - overlaps when a = Byte +instance IncoherentBase (Vector n Byte) where + baseMethod _ = "byte vector instance" diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Coherent.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Coherent.bs new file mode 100644 index 000000000..e21bbb38e --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Coherent.bs @@ -0,0 +1,40 @@ +package Instance_Coherent where + +import IncoherentBase +import Vector + +class coherent DependingCoherent a where + dependMethod :: a -> String + +instance (IncoherentBase a) => DependingCoherent a where + dependMethod x = "coherent " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +-- Case 1: Direct Byte vector - incoherent +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in dependMethod v + +-- Case 2: Direct Int vector - coherent +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in dependMethod v + +-- Case 3: Byte via generic - polymorphic forces generic instance +useGeneric :: Vector n a -> String +useGeneric v = dependMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysInstance_Coherent :: Module Empty +sysInstance_Coherent = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Default.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Default.bs new file mode 100644 index 000000000..c3f2fcc4f --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Default.bs @@ -0,0 +1,37 @@ +package Instance_Default where + +import IncoherentBase +import Vector + +class DependingDefault a where + dependMethod :: a -> String + +instance (IncoherentBase a) => DependingDefault a where + dependMethod x = "default " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in dependMethod v + +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in dependMethod v + +useGeneric :: Vector n a -> String +useGeneric v = dependMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysInstance_Default :: Module Empty +sysInstance_Default = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Incoherent.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Incoherent.bs new file mode 100644 index 000000000..834d923a6 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Instance_Incoherent.bs @@ -0,0 +1,37 @@ +package Instance_Incoherent where + +import IncoherentBase +import Vector + +class incoherent DependingIncoherent a where + dependMethod :: a -> String + +instance (IncoherentBase a) => DependingIncoherent a where + dependMethod x = "incoherent " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in dependMethod v + +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in dependMethod v + +useGeneric :: Vector n a -> String +useGeneric v = dependMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysInstance_Incoherent :: Module Empty +sysInstance_Incoherent = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Makefile b/testsuite/bsc.typechecker/typeclasses/coherence/Makefile new file mode 100644 index 000000000..607fb8db7 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Makefile @@ -0,0 +1,5 @@ +# for "make clean" to work everywhere + +CONFDIR = $(realpath ../../..) + +include $(CONFDIR)/clean.mk diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Super_Coherent.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Coherent.bs new file mode 100644 index 000000000..b4912d02f --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Coherent.bs @@ -0,0 +1,37 @@ +package Super_Coherent where + +import IncoherentBase +import Vector + +class coherent (IncoherentBase a) => SuperCoherent a where + superMethod :: a -> String + +instance SuperCoherent (Vector n a) where + superMethod x = "super coherent " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in superMethod v + +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in superMethod v + +useGeneric :: Vector n a -> String +useGeneric v = superMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysSuper_Coherent :: Module Empty +sysSuper_Coherent = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Super_Default.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Default.bs new file mode 100644 index 000000000..faaf3486f --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Default.bs @@ -0,0 +1,37 @@ +package Super_Default where + +import IncoherentBase +import Vector + +class (IncoherentBase a) => SuperDefault a where + superMethod :: a -> String + +instance SuperDefault (Vector n a) where + superMethod x = "super default " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in superMethod v + +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in superMethod v + +useGeneric :: Vector n a -> String +useGeneric v = superMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysSuper_Default :: Module Empty +sysSuper_Default = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/Super_Incoherent.bs b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Incoherent.bs new file mode 100644 index 000000000..5aa9532f6 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/Super_Incoherent.bs @@ -0,0 +1,37 @@ +package Super_Incoherent where + +import IncoherentBase +import Vector + +class incoherent (IncoherentBase a) => SuperIncoherent a where + superMethod :: a -> String + +instance SuperIncoherent (Vector n a) where + superMethod x = "super incoherent " +++ printType (typeOf x) +++ ": " +++ baseMethod x + +testByteDirect :: String +testByteDirect = + let v :: Vector 4 Byte + v = replicate 0 + in superMethod v + +testIntDirect :: String +testIntDirect = + let v :: Vector 4 (Int 8) + v = replicate 0 + in superMethod v + +useGeneric :: Vector n a -> String +useGeneric v = superMethod v + +testByteViaGeneric :: String +testByteViaGeneric = useGeneric ((replicate 0) :: Vector 4 Byte) + +sysSuper_Incoherent :: Module Empty +sysSuper_Incoherent = module + rules + "show": when True ==> do + $display "Byte direct: " testByteDirect + $display "Int direct: " testIntDirect + $display "Byte via generic: " testByteViaGeneric + $finish 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/coherence.exp b/testsuite/bsc.typechecker/typeclasses/coherence/coherence.exp new file mode 100644 index 000000000..7ea1c22f5 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/coherence.exp @@ -0,0 +1,50 @@ +# Tests for transitive incoherence diagnostics (T0158: an error normally, +# a warning under -incoherent-instance-matches or for classes annotated +# incoherent). +# IncoherentBase defines a class marked `incoherent` with a generic and a more +# specific overlapping instance. Each Instance_* test derives another class +# (coherent, incoherent, or default-annotation) whose instance depends on +# IncoherentBase via a proviso. Each Super_* test uses IncoherentBase as a +# superclass constraint instead. + +# ---- Instance-level proviso constraints ---- + +# coherent class depending on incoherent resolution: compile error T0158. +compile_fail_error Instance_Coherent.bs T0158 + +# default class (no annotation): T0158 error when the flag is off, T0158 +# warning when it is on. One source serves both runs: the flag-off compile +# fails (so it leaves no .bo behind for -u to reuse) and the flag-on run +# compiles fresh. +compile_fail_error Instance_Default.bs T0158 + +test_c_veri_bs_modules_options Instance_Default {} {-incoherent-instance-matches} +find_n_warning Instance_Default.bs.bsc-vcomp-out T0158 1 + +# incoherent class: transitive incoherence is suppressed (0 T0158 warnings). +test_c_veri_bs_modules_options Instance_Incoherent {} {} +find_n_warning Instance_Incoherent.bs.bsc-vcomp-out T0158 0 + +# ---- Superclass constraints ---- + +# Super_* classes use IncoherentBase as a superclass. The incoherent match is +# captured once inside the top-level dictionary function and applied uniformly +# to all callers, so behaviour is coherent from the callers' perspective. +# No T0158 warning is expected. + +test_c_veri_bs_modules_options Super_Coherent {} {} +find_n_warning Super_Coherent.bs.bsc-vcomp-out T0158 0 + +# The default-annotation class compiles cleanly with the flag both off and +# on, with identical sim output, so one source and one expected file serve +# both runs. Erase the .bo in between: bsc -u would otherwise see it as up +# to date and skip recompiling under the new flags. +test_c_veri_bs_modules_options Super_Default {} {} +find_n_warning Super_Default.bs.bsc-vcomp-out T0158 0 + +erase Super_Default.bo +test_c_veri_bs_modules_options Super_Default {} {-incoherent-instance-matches} +find_n_warning Super_Default.bs.bsc-vcomp-out T0158 0 + +test_c_veri_bs_modules_options Super_Incoherent {} {} +find_n_warning Super_Incoherent.bs.bsc-vcomp-out T0158 0 diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Coherent.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Coherent.out.expected new file mode 100644 index 000000000..f7f991dee --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Coherent.out.expected @@ -0,0 +1,3 @@ +Byte direct: coherent Vector.Vector 4 (Prelude.Bit 8): byte vector instance +Int direct: coherent Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: coherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Default.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Default.out.expected new file mode 100644 index 000000000..d4399aa24 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Default.out.expected @@ -0,0 +1,3 @@ +Byte direct: default Vector.Vector 4 (Prelude.Bit 8): byte vector instance +Int direct: default Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: default Vector.Vector 4 (Prelude.Bit 8): generic vector instance diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Incoherent.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Incoherent.out.expected new file mode 100644 index 000000000..5360b07ff --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysInstance_Incoherent.out.expected @@ -0,0 +1,3 @@ +Byte direct: incoherent Vector.Vector 4 (Prelude.Bit 8): byte vector instance +Int direct: incoherent Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: incoherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Coherent.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Coherent.out.expected new file mode 100644 index 000000000..d6000fd5f --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Coherent.out.expected @@ -0,0 +1,3 @@ +Byte direct: super coherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance +Int direct: super coherent Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: super coherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Default.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Default.out.expected new file mode 100644 index 000000000..7d7ca54e9 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Default.out.expected @@ -0,0 +1,3 @@ +Byte direct: super default Vector.Vector 4 (Prelude.Bit 8): generic vector instance +Int direct: super default Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: super default Vector.Vector 4 (Prelude.Bit 8): generic vector instance diff --git a/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Incoherent.out.expected b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Incoherent.out.expected new file mode 100644 index 000000000..18ee85775 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/coherence/sysSuper_Incoherent.out.expected @@ -0,0 +1,3 @@ +Byte direct: super incoherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance +Int direct: super incoherent Vector.Vector 4 (Prelude.Int 8): generic vector instance +Byte via generic: super incoherent Vector.Vector 4 (Prelude.Bit 8): generic vector instance From 36bff1fa34f6d7aaea731f52114a3f385fd55c8e Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 19:12:53 -0700 Subject: [PATCH 04/18] Tweak ITransform to get more pack-unpack to optimize properly This is a squash merge of GitHub PR 926. Add the following simplification rule to ITransform: if c then undefined else e --> e This fires during the improveIf fallthrough in IExpand for patterns like invalid enum tag arms, eliminating redundant case blocks that BSC was generating for pack/unpack of sum types. The symmetric rule (if c then e else undefined --> e) is intentionally absent: pack/unpack identity chains produce "if (x==k) k undefined" with ICUndet in the else branch, and firing there would collapse the chain before the k->x rule can convert it into an identity. New test case and test fixes. --- src/comp/ITransform.hs | 8 +++ .../Input_Output_Path/Input_Output_Path.exp | 5 +- .../actionvalue/log2_loop.exp.golden | 2 +- ...RATest2_sat-stp.bsv.bsc-sched-out.expected | 50 +++------------ ...Test2_sat-yices.bsv.bsc-sched-out.expected | 50 +++------------ ...tRATest_sat-stp.bsv.bsc-sched-out.expected | 50 +++------------ ...ATest_sat-yices.bsv.bsc-sched-out.expected | 50 +++------------ .../bsc.verilog/derived_bits/TestNoopCase.bs | 54 ++++++++++++++++ .../derived_bits/TestNoopTernary.bs | 63 +++++++++++++++++++ .../bsc.verilog/derived_bits/derived_bits.exp | 11 ++++ testsuite/bsc.verilog/opt/TestDoubleNorm.bs | 62 ++++++++++++++++++ testsuite/bsc.verilog/opt/opt.exp | 3 + testsuite/bsc.verilog/undet/undet.exp | 12 +--- 13 files changed, 246 insertions(+), 174 deletions(-) create mode 100644 testsuite/bsc.verilog/derived_bits/TestNoopCase.bs create mode 100644 testsuite/bsc.verilog/derived_bits/TestNoopTernary.bs create mode 100644 testsuite/bsc.verilog/opt/TestDoubleNorm.bs diff --git a/src/comp/ITransform.hs b/src/comp/ITransform.hs index 28f15f0aa..a6362dbe9 100644 --- a/src/comp/ITransform.hs +++ b/src/comp/ITransform.hs @@ -423,6 +423,14 @@ iTrAp ctx p@(ICon _ (ICPrim _ PrimIf)) [t] [cnd, thn, els] (_,_,IAps (ICon _ (ICPrim _ PrimBNot)) _ [x]) | eqE cnd x -> iTrAp2 ctx p [t] [cnd,thn,iTrue] + -- if c then _ else e --> e + -- This is more aggressive than just matching UNoMatch, but + -- it appears to make a positive difference. + -- Note that enabling the symmetric simplification for thn + -- when els is a don't care disturbs the expected pack . unpack + -- structure and makes some things worse while fixing others. + (_, ICon _ (ICUndet {}), _) -> (els, True) + _ -> (IAps p [t] [cnd, thn, els], False) -- Boolean optimization diff --git a/testsuite/bsc.interra/Path_Analysis/Input_Output_Path/Input_Output_Path.exp b/testsuite/bsc.interra/Path_Analysis/Input_Output_Path/Input_Output_Path.exp index fcd793541..0f109bb80 100755 --- a/testsuite/bsc.interra/Path_Analysis/Input_Output_Path/Input_Output_Path.exp +++ b/testsuite/bsc.interra/Path_Analysis/Input_Output_Path/Input_Output_Path.exp @@ -39,10 +39,7 @@ compare_file "En2ReturnValue.bsv.bsc-vcomp-out" compile_verilog_pass MuxMethods1.bsv mkMuxMethods1 "-dpathsPostSched" compare_file "MuxMethods1.bsv.bsc-vcomp-out" -# This used to compile, but now fails because of don't-care in the rule -# conditions. We could rewrite the condition to make a version (MuxMethods3) -# that does compile. -compile_verilog_fail_error MuxMethods2.bsv G0002 1 +compile_verilog_pass MuxMethods2.bsv compile_verilog_pass Parameter2Rdy.bsv mkParameter2Rdy "-dpathsPostSched" compare_file "Parameter2Rdy.bsv.bsc-vcomp-out" diff --git a/testsuite/bsc.long_tests/log2_loop/actionvalue/log2_loop.exp.golden b/testsuite/bsc.long_tests/log2_loop/actionvalue/log2_loop.exp.golden index 78a4513c5..c2b041d9b 100644 --- a/testsuite/bsc.long_tests/log2_loop/actionvalue/log2_loop.exp.golden +++ b/testsuite/bsc.long_tests/log2_loop/actionvalue/log2_loop.exp.golden @@ -1 +1 @@ -test_veri_only_bsv_modules_options Log2Test "" "+RTS -H150M -M300M -Sstderr -RTS" out.expected +test_veri_only_bsv_modules_options Log2Test "" "-steps 2000000 +RTS -H150M -M300M -K30M -Sstderr -RTS" out.expected diff --git a/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-stp.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-stp.bsv.bsc-sched-out.expected index bf55bb643..7102859ad 100644 --- a/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-stp.bsv.bsc-sched-out.expected +++ b/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-stp.bsv.bsc-sched-out.expected @@ -20,7 +20,7 @@ order: [RL_aa, RL_ab, RL_bb] (ub.read, [(ub.read, 1)]), (uc.read, [(uc.read, 1)]), (uc.write, - [(uc.write uc_PLUS_1___d8, 1), (uc.write uc_PLUS_2___d27, 1), (uc.write uc_PLUS_3___d30, 1)])] + [(uc.write uc_PLUS_1___d6, 1), (uc.write uc_PLUS_2___d25, 1), (uc.write uc_PLUS_3___d28, 1)])] ----- @@ -35,54 +35,24 @@ Schedule dump file created: sysShiftRATest.sched Rule schedule ------------- Rule: aa -Predicate: (ua >>> - (ub[30] - ? (_ :: Bit 31) - : ub)) == - 18'd17 +Predicate: (ua >>> ub) == 18'd17 Blocking rules: (none) Rule: ab -Predicate: ! ((((ua[17] && - (! (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17])) || - ((! ua[17]) && - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17])) +Predicate: ! ((((ua[17] && (! (31'd1 << ub)[17])) || + ((! ua[17]) && (31'd1 << ub)[17])) ? - ((ua[17] ? - ua : ua) / - ((31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17] - ? - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0] - : (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0])) + ((31'd1 << ub)[17] + ? - (31'd1 << ub)[17:0] + : (31'd1 << ub)[17:0])) : ((ua[17] ? - ua : ua) / - ((31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17] - ? - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0] - : (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0]))) == + ((31'd1 << ub)[17] + ? - (31'd1 << ub)[17:0] + : (31'd1 << ub)[17:0]))) == 18'd17) Blocking rules: (none) diff --git a/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-yices.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-yices.bsv.bsc-sched-out.expected index 3b996709e..cf2864f43 100644 --- a/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-yices.bsv.bsc-sched-out.expected +++ b/testsuite/bsc.scheduler/sat/ShiftRATest2_sat-yices.bsv.bsc-sched-out.expected @@ -20,7 +20,7 @@ order: [RL_aa, RL_ab, RL_bb] (ub.read, [(ub.read, 1)]), (uc.read, [(uc.read, 1)]), (uc.write, - [(uc.write uc_PLUS_1___d8, 1), (uc.write uc_PLUS_2___d27, 1), (uc.write uc_PLUS_3___d30, 1)])] + [(uc.write uc_PLUS_1___d6, 1), (uc.write uc_PLUS_2___d25, 1), (uc.write uc_PLUS_3___d28, 1)])] ----- @@ -35,54 +35,24 @@ Schedule dump file created: sysShiftRATest.sched Rule schedule ------------- Rule: aa -Predicate: (ua >>> - (ub[30] - ? (_ :: Bit 31) - : ub)) == - 18'd17 +Predicate: (ua >>> ub) == 18'd17 Blocking rules: (none) Rule: ab -Predicate: ! ((((ua[17] && - (! (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17])) || - ((! ua[17]) && - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17])) +Predicate: ! ((((ua[17] && (! (31'd1 << ub)[17])) || + ((! ua[17]) && (31'd1 << ub)[17])) ? - ((ua[17] ? - ua : ua) / - ((31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17] - ? - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0] - : (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0])) + ((31'd1 << ub)[17] + ? - (31'd1 << ub)[17:0] + : (31'd1 << ub)[17:0])) : ((ua[17] ? - ua : ua) / - ((31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17] - ? - (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0] - : (31'd1 << - (ub[30] - ? (_ :: Bit 31) - : ub))[17:0]))) == + ((31'd1 << ub)[17] + ? - (31'd1 << ub)[17:0] + : (31'd1 << ub)[17:0]))) == 18'd17) Blocking rules: (none) diff --git a/testsuite/bsc.scheduler/sat/ShiftRATest_sat-stp.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/ShiftRATest_sat-stp.bsv.bsc-sched-out.expected index b1d7601a8..fdce1d13e 100644 --- a/testsuite/bsc.scheduler/sat/ShiftRATest_sat-stp.bsv.bsc-sched-out.expected +++ b/testsuite/bsc.scheduler/sat/ShiftRATest_sat-stp.bsv.bsc-sched-out.expected @@ -20,7 +20,7 @@ order: [RL_aa, RL_ab, RL_bb] (ub.read, [(ub.read, 1)]), (uc.read, [(uc.read, 1)]), (uc.write, - [(uc.write uc_PLUS_1___d8, 1), (uc.write uc_PLUS_2___d26, 1), (uc.write uc_PLUS_3___d29, 1)])] + [(uc.write uc_PLUS_1___d6, 1), (uc.write uc_PLUS_2___d24, 1), (uc.write uc_PLUS_3___d27, 1)])] ----- @@ -35,54 +35,24 @@ Schedule dump file created: sysShiftRATest.sched Rule schedule ------------- Rule: aa -Predicate: (ua >>> - (ub[17] - ? (_ :: Bit 18) - : ub)) == - 18'd17 +Predicate: (ua >>> ub) == 18'd17 Blocking rules: (none) Rule: ab -Predicate: ! ((((ua[17] && - (! (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17])) || - ((! ua[17]) && - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17])) +Predicate: ! ((((ua[17] && (! (18'd1 << ub)[17])) || + ((! ua[17]) && (18'd1 << ub)[17])) ? - ((ua[17] ? - ua : ua) / - ((18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17] - ? - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)) - : (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)))) + ((18'd1 << ub)[17] + ? - (18'd1 << ub) + : (18'd1 << ub))) : ((ua[17] ? - ua : ua) / - ((18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17] - ? - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)) - : (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))))) == + ((18'd1 << ub)[17] + ? - (18'd1 << ub) + : (18'd1 << ub)))) == 18'd17) Blocking rules: (none) diff --git a/testsuite/bsc.scheduler/sat/ShiftRATest_sat-yices.bsv.bsc-sched-out.expected b/testsuite/bsc.scheduler/sat/ShiftRATest_sat-yices.bsv.bsc-sched-out.expected index 2eda4d5d8..65dc596b2 100644 --- a/testsuite/bsc.scheduler/sat/ShiftRATest_sat-yices.bsv.bsc-sched-out.expected +++ b/testsuite/bsc.scheduler/sat/ShiftRATest_sat-yices.bsv.bsc-sched-out.expected @@ -20,7 +20,7 @@ order: [RL_aa, RL_ab, RL_bb] (ub.read, [(ub.read, 1)]), (uc.read, [(uc.read, 1)]), (uc.write, - [(uc.write uc_PLUS_1___d8, 1), (uc.write uc_PLUS_2___d26, 1), (uc.write uc_PLUS_3___d29, 1)])] + [(uc.write uc_PLUS_1___d6, 1), (uc.write uc_PLUS_2___d24, 1), (uc.write uc_PLUS_3___d27, 1)])] ----- @@ -35,54 +35,24 @@ Schedule dump file created: sysShiftRATest.sched Rule schedule ------------- Rule: aa -Predicate: (ua >>> - (ub[17] - ? (_ :: Bit 18) - : ub)) == - 18'd17 +Predicate: (ua >>> ub) == 18'd17 Blocking rules: (none) Rule: ab -Predicate: ! ((((ua[17] && - (! (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17])) || - ((! ua[17]) && - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17])) +Predicate: ! ((((ua[17] && (! (18'd1 << ub)[17])) || + ((! ua[17]) && (18'd1 << ub)[17])) ? - ((ua[17] ? - ua : ua) / - ((18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17] - ? - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)) - : (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)))) + ((18'd1 << ub)[17] + ? - (18'd1 << ub) + : (18'd1 << ub))) : ((ua[17] ? - ua : ua) / - ((18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))[17] - ? - (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub)) - : (18'd1 << - (ub[17] - ? (_ :: Bit 18) - : ub))))) == + ((18'd1 << ub)[17] + ? - (18'd1 << ub) + : (18'd1 << ub)))) == 18'd17) Blocking rules: (none) diff --git a/testsuite/bsc.verilog/derived_bits/TestNoopCase.bs b/testsuite/bsc.verilog/derived_bits/TestNoopCase.bs new file mode 100644 index 000000000..e7f63aa46 --- /dev/null +++ b/testsuite/bsc.verilog/derived_bits/TestNoopCase.bs @@ -0,0 +1,54 @@ +package TestNoopCase where + +-- Issue: pack . unpack on a derived-Bits sum type generates a case statement +-- where every branch produces the same expression — a no-op. +-- +-- When BSC synthesizes a register of type T, the read and write paths +-- each evaluate pack(unpack(bits)) symbolically. For a sum type with +-- `deriving Bits`, BSC lays out all constructor payloads right-aligned in +-- the same bit positions. Unused padding bits are left don't-care. When +-- tracing pack(unpack(bits)) through each constructor, every branch +-- resolves to the same bit slice. The case is generated but is a no-op. +-- +-- Threshold: the bug manifests at 7 constructors (3-bit tag). With fewer +-- constructors BSC folds the case away at elaboration time. +-- +-- Compile: +-- bsc -verilog -p .:%/Libraries -bdir build -vdir verilog TestNoopCase.bs +-- +-- ----------------------------------------------------------------------- +-- Generated Verilog: +-- +-- reg [3:0] CASE_..._q1, CASE_..._q2; +-- assign _read = {r[6:4], q1}; +-- assign r$D_IN = {_write_1[6:4], q2}; +-- +-- always@(r) begin +-- case (r[6:4]) // switch on constructor tag +-- 3'd1, 3'd2, 3'd4: q1 = r[3:0]; +-- default: q1 = r[3:0]; // every branch is identical +-- endcase +-- end +-- // identical always block for _write_1 / q2 +-- +-- Should be: +-- +-- assign _read = r; +-- assign r$D_IN = _write_1; + +-- 7-constructor sum type: 3-bit tag, 4-bit max payload, 7 bits total. +data Sum7 + = S7_0 + | S7_1 (UInt 4) + | S7_2 (UInt 1) + | S7_3 + | S7_4 (UInt 1) + | S7_5 + | S7_6 (UInt 1) + deriving (Bits) + +{-# verilog mkTestNoopCase #-} +mkTestNoopCase :: (IsModule m c) => m (Reg Sum7) +mkTestNoopCase = module + r :: Reg Sum7 <- mkRegU + return r diff --git a/testsuite/bsc.verilog/derived_bits/TestNoopTernary.bs b/testsuite/bsc.verilog/derived_bits/TestNoopTernary.bs new file mode 100644 index 000000000..6f8ba7208 --- /dev/null +++ b/testsuite/bsc.verilog/derived_bits/TestNoopTernary.bs @@ -0,0 +1,63 @@ +package TestNoopTernary where + +-- Issue: pack . unpack on a two-constructor sum type generates a ternary +-- expression whose branches are identical — a no-op — when the larger +-- payload itself contains a derived-Bits sum type (see TestNoopCase). +-- +-- When the larger constructor wraps a Sum7 value (7-constructor sub-type), +-- the inner pack(unpack()) trace produces a no-op case for that sub-type +-- (all inner branches = same bit slice). This causes the outer ternary +-- (which gates on the 1-bit constructor tag) to also have identical branches. +-- +-- Compile: +-- bsc -verilog -p .:%/Libraries -bdir build -vdir verilog TestNoopTernary.bs +-- +-- ----------------------------------------------------------------------- +-- Generated Verilog: +-- +-- reg [3:0] CASE_..._q1, CASE_..._q2; +-- assign _read = +-- { r[7], +-- r[7] ? { r[6:4], CASE_..._q1 } // Large constructor: = r[6:0] +-- : r[6:0] }; // Small constructor: = r[6:0] +-- // Both branches equal r[6:0], so: _read = {r[7], r[6:0]} = r +-- +-- // Inner case (q1) is a no-op — every branch is the same: +-- always@(r) begin +-- case (r[6:4]) +-- 3'd1, 3'd2, 3'd4: q1 = r[3:0]; +-- default: q1 = r[3:0]; +-- endcase +-- end +-- // identical always block for _write_1 / q2 +-- +-- Should be: +-- +-- assign _read = r; +-- assign r$D_IN = _write_1; + +-- 7-constructor sub-type that triggers the inner no-op case. +data Sum7 + = S7_0 + | S7_1 (UInt 4) + | S7_2 (UInt 1) + | S7_3 + | S7_4 (UInt 1) + | S7_5 + | S7_6 (UInt 1) + deriving (Bits) + +-- Two-constructor sum type: +-- tag=0, 2-bit payload (smaller constructor) +-- tag=1, 7-bit payload (larger constructor, wraps Sum7) +-- Total: 1 tag + 7 payload = 8 bits. +data BigSmall + = Small (UInt 2) + | Big Sum7 + deriving (Bits) + +{-# verilog mkTestNoopTernary #-} +mkTestNoopTernary :: (IsModule m c) => m (Reg BigSmall) +mkTestNoopTernary = module + r :: Reg BigSmall <- mkRegU + return r diff --git a/testsuite/bsc.verilog/derived_bits/derived_bits.exp b/testsuite/bsc.verilog/derived_bits/derived_bits.exp index 2cac5e782..7594de8ae 100644 --- a/testsuite/bsc.verilog/derived_bits/derived_bits.exp +++ b/testsuite/bsc.verilog/derived_bits/derived_bits.exp @@ -66,3 +66,14 @@ string_does_not_occur mkDecoder.v "xxxx" string_does_not_occur mkDecoder.v "unspecified value" string_does_not_occur mkDecoder.v "\?" string_does_not_occur mkDecoder.v "case" + +compile_verilog_pass TestNoopCase.bs "" "-opt-undetermined-vals" +find_n_strings mkTestNoopCase.v "case" 0 +find_regexp mkTestNoopCase.v {assign _read = r ;} +find_regexp mkTestNoopCase.v {assign r\$D_IN = _write_1 ;} + +compile_verilog_pass TestNoopTernary.bs "" "-opt-undetermined-vals" +find_n_strings mkTestNoopTernary.v "?" 0 +find_regexp mkTestNoopTernary.v {assign _read = r ;} +find_regexp mkTestNoopTernary.v {assign r\$D_IN = _write_1 ;} + diff --git a/testsuite/bsc.verilog/opt/TestDoubleNorm.bs b/testsuite/bsc.verilog/opt/TestDoubleNorm.bs new file mode 100644 index 000000000..9294540c1 --- /dev/null +++ b/testsuite/bsc.verilog/opt/TestDoubleNorm.bs @@ -0,0 +1,62 @@ +package TestDoubleNorm where + +-- Issue: pack . unpack is applied on both the write path (necessary) and +-- the read path (redundant) when pack . unpack is a normalization function. +-- +-- For a type with a custom Bits instance where pack(unpack(x)) normalizes x +-- to a canonical form, the write path correctly stores only canonical values. +-- The read path then applies pack(unpack()) again, but since r is already +-- canonical, pack(unpack(r)) = r — the read-side application is redundant. +-- +-- BSC does not detect this: it generates pack(unpack()) on both paths +-- unconditionally. +-- +-- Compile: +-- bsc -verilog -p .:%/Libraries -bdir build -vdir verilog TestDoubleNorm.bs +-- +-- ----------------------------------------------------------------------- +-- Generated Verilog: +-- +-- wire [4:0] x__h_inv_r, x__h_inv_w; +-- assign x__h_inv_r = ~r; +-- assign x__h_inv_w = ~_write_1; +-- +-- // READ path — pack(unpack(r)), redundant since r is already canonical: +-- assign _read = (r == 5'd0) ? r : {1'b1, ~x__h_inv_r[3:0]}; +-- +-- // WRITE path — pack(unpack(_write_1)), necessary to normalize input: +-- assign r$D_IN = (_write_1 == 5'd0) ? _write_1 : {1'b1, ~x__h_inv_w[3:0]}; +-- +-- Should be: +-- +-- assign _read = r; -- r is already canonical; no normalization needed +-- assign r$D_IN = (_write_1 == 5'd0) ? _write_1 : {1'b1, ~(~_write_1)[3:0]}; +-- +-- ----------------------------------------------------------------------- +-- Encoding for Opt4 (a 4-bit optional unsigned with inverted representation): +-- +-- pack None4 = 5'b00000 +-- pack (Some4 x) = ~{1'b0, x[3:0]} = {1'b1, ~x[3:0]} +-- +-- Canonical values: 5'b00000 or 5'b1xxxx. +-- Non-canonical: 5'b0xxxx with x != 0 (cannot arise after a canonical write). +-- +-- pack(unpack(v)) = (v == 0) ? 0 : {1'b1, ~v[3:0]} -- the normalization fn +-- For canonical v: pack(unpack(v)) = v. -- identity on canonical + +data Opt4 = None4 | Some4 (UInt 4) + +instance Bits Opt4 5 where + pack i = case i of + None4 -> 0 + Some4 x -> invert $ zeroExtend $ pack x + unpack b = + if b == 0 + then None4 + else Some4 $ unpack $ truncate $ invert b + +{-# verilog mkTestDoubleNorm #-} +mkTestDoubleNorm :: (IsModule m c) => m (Reg Opt4) +mkTestDoubleNorm = module + r :: Reg Opt4 <- mkRegU + return r diff --git a/testsuite/bsc.verilog/opt/opt.exp b/testsuite/bsc.verilog/opt/opt.exp index f83f31fa4..0f553b46a 100644 --- a/testsuite/bsc.verilog/opt/opt.exp +++ b/testsuite/bsc.verilog/opt/opt.exp @@ -88,3 +88,6 @@ if { $vtest == 1 } { # --------------- +compile_verilog_pass TestDoubleNorm.bs +find_n_strings_bug mkTestDoubleNorm.v "?" 1 "731" +find_regexp_bug mkTestDoubleNorm.v {assign _read = r ;} "731" diff --git a/testsuite/bsc.verilog/undet/undet.exp b/testsuite/bsc.verilog/undet/undet.exp index 3582ca75c..7f9cb102e 100644 --- a/testsuite/bsc.verilog/undet/undet.exp +++ b/testsuite/bsc.verilog/undet/undet.exp @@ -17,13 +17,7 @@ if { $vtest == 1 } { # Make sure 13-bit y values are optimized away. string_does_not_occur sysUndetComp.v "13'd" - # Undefined values before the end currently trigger unnecessary != tests - # We should test: - # string_does_not_occur sysUndetComp.v "!=" - - # but until this is fixed check that the expected number are present: - find_n_strings sysUndetComp.v "!=" 2 - - # Note: This is 2, rather than the 3 not-equal comparisons that are actually - # in the file because of a bug with find_n_strings: https://github.com/B-Lang-org/bsc-testsuite/issues/21 + # Undefined values before the end of the if-else tree used to trigger + # unnecessary != tests; check that none are generated: + string_does_not_occur sysUndetComp.v "!=" } From 24acc7fd75a433c256f1c5fb4efac53d64f66046 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 19:15:50 -0700 Subject: [PATCH 05/18] Verilog code-gen performance improvement (VMItems) GitHub PR 929. Use a size/type map instead of crawling the list of VMItems. --- src/comp/AVerilog.hs | 108 ++++++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 48 deletions(-) diff --git a/src/comp/AVerilog.hs b/src/comp/AVerilog.hs index 438d735a8..67b713ebb 100644 --- a/src/comp/AVerilog.hs +++ b/src/comp/AVerilog.hs @@ -352,7 +352,7 @@ aVerilog errh flags pps aspack ffmap = -- remember to not redeclare any signals that needed to be -- declared for submodule instantiations - isPreDeclared = isDeclFromList inst_declared_signals + isPreDeclared = isDeclFromList $ S.fromList inst_declared_signals -- make a map to hold the defs, for easy access defmap = M.fromList [ (i,d) | d@(ADef i _ _ _) <- ds ] @@ -813,6 +813,8 @@ genInstances errh flags ff_blocks vDef aspack = -- converts the adefs to vitems defs = concatMap vDef (aspkg_values aspack) + -- make a size and type map from the vmitems + sztm = mkSizeAndTypeMap defs -- we'll need the inout defs, too, to know which inout ports -- of submodule are used (and which should be left unconnected) @@ -907,7 +909,7 @@ genInstances errh flags ff_blocks vDef aspack = -- generate the reg/wire declarations reg_decl_groups = - map (mkRegGroup sos defs inlined_reg_comments) reg_infos + map (mkRegGroup sos sztm inlined_reg_comments) reg_infos -- the input wire decls (to be later assigned to, but not re-declared) reg_inputs :: [(AId, [VId])] @@ -1003,14 +1005,14 @@ genInstances errh flags ff_blocks vDef aspack = in partition ((`elem` probe_ids) . fst) noninlinedreg_comments (probe_inputs, probe_decls_group) = - mkProbeGroup sos defs probe_comments probe_infos + mkProbeGroup sos sztm probe_comments probe_infos -- ---------- -- generate a group for inlined rwires whose i/o are still around -- user comments on rwires are handled with "inlined_submod_comments" -- (note that InlineRWire could convert them to PPdoc on the topmod) - (rwire_inputs, rwire_decls_group) = mkRWireGroup filtered_defs rws + (rwire_inputs, rwire_decls_group) = mkRWireGroup (mkSizeAndTypeMap filtered_defs) rws -- ---------- -- signals declared so far @@ -1036,7 +1038,7 @@ genInstances errh flags ff_blocks vDef aspack = (submod_inputs, submod_decl_groups, submod_def_groups, extra_submod_decls) = - mkSubmodGroups flags sos defs submod_comments decls_so_far + mkSubmodGroups flags sos sztm submod_comments decls_so_far submod_infos -- ---------- @@ -1123,15 +1125,15 @@ genInstances errh flags ff_blocks vDef aspack = -- (any signals which are pre-declared are returned as the fourth item -- of the tuple) mkSubmodGroups :: - Flags -> [AStateOut] -> [VMItem] -> [(Id,[String])] -> [VId] -> + Flags -> [AStateOut] -> SizeAndTypeMap -> [(Id,[String])] -> [VId] -> [(AId, VMItem, InstInfo)] -> ([(AId, [VId])], [VMItem], [VMItem], [VId]) -mkSubmodGroups flags sos defs submod_comments decls_so_far submod_infos = +mkSubmodGroups flags sos sztm submod_comments decls_so_far submod_infos = let (submod_decl_groups, submod_def_groups) = apFst catMaybes $ apSnd catMaybes $ unzip $ - map (mkInstGroup flags sos defs submod_comments) submod_infos + map (mkInstGroup flags sos sztm submod_comments) submod_infos submod_inputs = let getInputs (i, _, (_,_,_,ins,_)) = (i, map snd ins) @@ -1145,7 +1147,7 @@ mkSubmodGroups flags sos defs submod_comments decls_so_far submod_infos = else let (new_submod_groups, extra_submod_decls) = - fixupSubmodGroups sos defs submod_infos decls_so_far + fixupSubmodGroups sos sztm submod_infos decls_so_far submod_decl_groups in -- check that the assumption is OK @@ -1155,9 +1157,9 @@ mkSubmodGroups flags sos defs submod_comments decls_so_far submod_infos = fixupSubmodGroups :: - [AStateOut] -> [VMItem] -> [(AId, VMItem, InstInfo)] -> [VId] -> + [AStateOut] -> SizeAndTypeMap -> [(AId, VMItem, InstInfo)] -> [VId] -> [VMItem] -> ([VMItem], [VId]) -fixupSubmodGroups sos defs submod_infos decls_so_far submod_groups = +fixupSubmodGroups sos sztm submod_infos decls_so_far submod_groups = let -- ---------- @@ -1209,21 +1211,21 @@ fixupSubmodGroups sos defs submod_infos decls_so_far submod_groups = (final_submod_groups, extra_submod_decls) = apFst reverse $ - foldl (addInstPortDecls defs decls_so_far) ([],[]) + foldl (addInstPortDecls sztm decls_so_far) ([],[]) sorted_inst_nodes in (final_submod_groups, extra_submod_decls) -- create a group of Verilog statements for a submodule instantiation -mkInstGroup :: Flags -> [AStateOut] -> [VMItem] -> [(Id,[String])] -> +mkInstGroup :: Flags -> [AStateOut] -> SizeAndTypeMap -> [(Id,[String])] -> (AId, VMItem, InstInfo) -> (Maybe VMItem, Maybe VMItem) -mkInstGroup flags sos defs comments_map (instname, vmi, info) = +mkInstGroup flags sos sztm comments_map (instname, vmi, info) = let (_, _, special, ins, outs) = info -- nub on the output values because there can be permissible overlap between -- "special" clock/reset outputs and method outputs wire_decls = - map (mkInstInputDecl defs instname . snd) ins ++ + map (mkInstInputDecl sztm instname . snd) ins ++ map (mkInstOutputDecl sos instname VDWire . snd) (nub (special ++ outs)) user_comment = case (lookup instname comments_map) of Nothing -> [] @@ -1251,13 +1253,13 @@ mkInstGroup flags sos defs comments_map (instname, vmi, info) = -- (each probe has one input, with obvious name, so no need to add a -- comment and empty line for each probe) -- (note that there is no instantiation for Probes, just the wire) -mkProbeGroup :: [AStateOut] -> [VMItem] -> [(Id, [String])] -> +mkProbeGroup :: [AStateOut] -> SizeAndTypeMap -> [(Id, [String])] -> [(AId, VMItem, InstInfo)] -> ([VId], [VMItem]) -mkProbeGroup sos defs comments_map probe_infos = +mkProbeGroup sos sztm comments_map probe_infos = let getProbeInput (instname, vmi, (_, _, _, inps, _)) = - map (mkInstInputDecl defs instname . snd) inps + map (mkInstInputDecl sztm instname . snd) inps -- we drop the vmi and just declare the input port -- (there shouldn't be any outputs) probe_decls = concatMap getProbeInput probe_infos @@ -1285,14 +1287,14 @@ mkProbeGroup sos defs comments_map probe_infos = else (decl_ids, [group]) -- create a group of Verilog statements for an inlined register "instantiation" -mkRegGroup :: [AStateOut] -> [VMItem] -> [(Id, [String])] -> +mkRegGroup :: [AStateOut] -> SizeAndTypeMap -> [(Id, [String])] -> RegInstInfo -> VMItem -mkRegGroup sos defs comments_map (inst_vid, def_name, _, inps, (out, out_size)) = +mkRegGroup sos sztm comments_map (inst_vid, def_name, _, inps, (out, out_size)) = let reg_decl = VMDecl (VVDecl VDReg out_size [VVar out]) -- if the EN is 0, then D_IN might not be defined! -- so have a backup in case the signal is not defined - inp_decls = map (mkInstInputDeclWithDefault defs) inps + inp_decls = map (mkInstInputDeclWithDefault sztm) inps all_decls = (reg_decl : mergeCommonDecl inp_decls) comments = lookupWithDefault comments_map [] (vidToId inst_vid) in VMRegGroup inst_vid @@ -1300,9 +1302,9 @@ mkRegGroup sos defs comments_map (inst_vid, def_name, _, inps, (out, out_size)) comments (VMGroup False [all_decls]) -mkRWireGroup :: [VMItem] -> [AId] -> ([VId], [VMItem]) -mkRWireGroup defs rws = - let rw_decls = mapMaybe (mkInstInputDeclMaybe defs . vId) rws +mkRWireGroup :: SizeAndTypeMap -> [AId] -> ([VId], [VMItem]) +mkRWireGroup sztm rws = + let rw_decls = mapMaybe (mkInstInputDeclMaybe sztm . vId) rws decl_ids = [ i | (VMDecl (VVDecl _ _ [VVar i])) <- rw_decls ] comment = ["inlined wires"] group = VMComment comment (VMGroup False [(mergeCommonDecl rw_decls)]) @@ -1315,17 +1317,17 @@ mkRWireGroup defs rws = -- when folded left along a tsort'ed list of instances, it inserts additional -- signal decls for signals used in non-method ports of the instantiations. -- the resulting list of VMItem groups is in reverse order (due to foldl). -addInstPortDecls :: [VMItem] -> [VId] -> +addInstPortDecls :: SizeAndTypeMap -> [VId] -> ([VMItem], [VId]) -> (AId, VMItem, [(VId,VExpr)]) -> ([VMItem], [VId]) -addInstPortDecls defs decls (gs, new_decls) (i, inst_g, ps) = +addInstPortDecls sztm decls (gs, new_decls) (i, inst_g, ps) = let -- variables used in the inst which have not already been declared -- (prior to submod instances or by an earlier submod inst) vs = [ i | (_, VEVar i) <- ps, i `notElem` (decls ++ new_decls) ] -- convert to decl - v_decls = map (mkInstInputDecl defs i) vs + v_decls = map (mkInstInputDecl sztm i) vs -- create a group for it decl_g = VMGroup False [mergeCommonDecl v_decls] in @@ -1351,29 +1353,29 @@ mkInstOutputDecl sos inst_id decl_type out_port_id = -- for a submodule input, lookup the size and create a Verilog decl -- of the appropriate size and type (some decls are defined with case-stmt) -mkInstInputDecl :: [VMItem] -> Id -> VId -> VMItem -mkInstInputDecl defs inst_id in_port_id = +mkInstInputDecl :: SizeAndTypeMap -> Id -> VId -> VMItem +mkInstInputDecl sztm inst_id in_port_id = let mkDecl i sz t = VMDecl (VVDecl t sz [VVar i]) - in case (getSizeAndTypeM in_port_id defs) of + in case (getSizeAndTypeM in_port_id sztm) of Just (sz, t) -> mkDecl in_port_id sz t Nothing -> internalError ("mkInstInputDecl: instance `" ++ getIdString inst_id ++ "' input port not found: " ++ getVIdString in_port_id ++ - "\n defs = " ++ - ppReadable defs) + "\n size and type map = " ++ + ppReadable sztm) -mkInstInputDeclWithDefault :: [VMItem] -> (VId, Maybe VRange) -> VMItem -mkInstInputDeclWithDefault defs (in_port_id, in_port_size) = +mkInstInputDeclWithDefault :: SizeAndTypeMap -> (VId, Maybe VRange) -> VMItem +mkInstInputDeclWithDefault sztm (in_port_id, in_port_size) = let mkDecl i sz t = VMDecl (VVDecl t sz [VVar i]) - in case (getSizeAndTypeM in_port_id defs) of + in case (getSizeAndTypeM in_port_id sztm) of Just (sz, t) -> mkDecl in_port_id sz t Nothing -> mkDecl in_port_id in_port_size VDWire -mkInstInputDeclMaybe :: [VMItem] -> VId -> Maybe VMItem -mkInstInputDeclMaybe defs in_port_id = +mkInstInputDeclMaybe :: SizeAndTypeMap -> VId -> Maybe VMItem +mkInstInputDeclMaybe sztm in_port_id = let mkDecl i sz t = VMDecl (VVDecl t sz [VVar i]) - in case (getSizeAndTypeM in_port_id defs) of + in case (getSizeAndTypeM in_port_id sztm) of Just (sz, t) -> Just (mkDecl in_port_id sz t) Nothing -> Nothing @@ -1639,18 +1641,28 @@ mergeCommonDecl ins = -- ============================== -getSizeAndTypeM :: VId -> [VMItem] -> Maybe (Maybe VRange, VDType) -getSizeAndTypeM i [] = Nothing -getSizeAndTypeM i (VMDecl (VVDWire sz (VVar i') _) : _) - | i == i' = Just (sz, VDWire) -getSizeAndTypeM i (VMDecl (VVDecl t sz vs) : _) - | (t == VDWire || t == VDReg) && i `elem` [ i | VVar i <- vs ] = Just (sz, t) -getSizeAndTypeM i (_ : ms) = getSizeAndTypeM i ms +type SizeAndTypeMap = M.Map VId (Maybe VRange, VDType) + +mkSizeAndTypeMap :: [VMItem] -> SizeAndTypeMap +mkSizeAndTypeMap defs = M.fromList $ + [ (i, (sz, VDWire)) | VMDecl (VVDWire sz (VVar i) _) <- defs ] ++ + [ (i, (sz, t)) | d@(VMDecl (VVDecl t sz vs)) <- defs, + checkDeclType t d, + VVar i <- vs ] + where + -- only wire and reg decls are expected in the defs + checkDeclType t d + | (t == VDWire) || (t == VDReg) = True + | otherwise = internalError ("mkSizeAndTypeMap: unexpected decl type: " ++ + ppReadable d) + +getSizeAndTypeM :: VId -> SizeAndTypeMap -> Maybe (Maybe VRange, VDType) +getSizeAndTypeM = M.lookup -- assumes that decls haven't been merged yet -isDeclFromList :: [VId] -> VMItem -> Bool -isDeclFromList is (VMDecl (VVDWire _ vv _)) = elem (vvName vv) is -isDeclFromList is (VMDecl (VVDecl _ _ [vv])) = elem (vvName vv) is +isDeclFromList :: S.Set VId -> VMItem -> Bool +isDeclFromList is (VMDecl (VVDWire _ vv _)) = vvName vv `S.member` is +isDeclFromList is (VMDecl (VVDecl _ _ [vv])) = vvName vv `S.member` is isDeclFromList _ _ = False -- lookup defs, maintaining their order, and returning the remaining defs From 5c2ab74016f1ee74156a202a41f1056617312f5e Mon Sep 17 00:00:00 2001 From: michael-roe <2479665+michael-roe@users.noreply.github.com> Date: Sat, 11 Jul 2026 03:18:00 +0100 Subject: [PATCH 06/18] Fix FloatToFixed of a denormalized number GitHub PR 933. --- src/Libraries/Base3-Math/FloatingPoint.bsv | 27 ++- testsuite/bsc.lib/FloatingPoint/FloatTest.exp | 6 + .../FloatingPoint/FloatToFixed_RoundMode.bsv | 180 ++++++++++++++++++ .../sysFloatToFixed_RoundMode.out.expected | 34 ++++ 4 files changed, 238 insertions(+), 9 deletions(-) create mode 100644 testsuite/bsc.lib/FloatingPoint/FloatToFixed_RoundMode.bsv create mode 100644 testsuite/bsc.lib/FloatingPoint/sysFloatToFixed_RoundMode.out.expected diff --git a/src/Libraries/Base3-Math/FloatingPoint.bsv b/src/Libraries/Base3-Math/FloatingPoint.bsv index c947925d5..9923bbeb2 100644 --- a/src/Libraries/Base3-Math/FloatingPoint.bsv +++ b/src/Libraries/Base3-Math/FloatingPoint.bsv @@ -3153,8 +3153,6 @@ instance FixedFloatCVT#(FloatingPoint#(e,m),UInt#(n)) out = 0; end else begin - // todo: does this work for subnormal? - UInt#(TAdd#(n,TAdd#(m,2))) sfd = unpack(zExtendLSB({getHiddenBit(fl), fl.sfd})); Int#(TAdd#(TAdd#(TAdd#(e,1),TLog#(m)),ln)) shft = -signExtend(unpack(unbias(fl))) + fromInteger(valueOf(n)) - 1 - zeroExtend(unpack(pack(frac))); @@ -3163,7 +3161,12 @@ instance FixedFloatCVT#(FloatingPoint#(e,m),UInt#(n)) exc.invalid_op = True; // overflow signals invalid op end else if (shft > fromInteger(valueOf(n))) begin - out = 0; + if (rmode == Rnd_Minus_Inf && fl.sign) + out = -1; + else if (rmode == Rnd_Plus_Inf && !fl.sign) + out = 1; + else + out = 0; exc.inexact = True; end else begin @@ -3303,8 +3306,6 @@ instance FixedFloatCVT#(FloatingPoint#(e,m),Int#(n)) out = 0; end else begin - // todo: does this work for subnormal? - // needs to be large so bits aren't lost before rounding Int#(TAdd#(n,TAdd#(m,2))) sfd = fl.sign ? -unpack(zExtendLSB({1'b0, getHiddenBit(fl), fl.sfd})) : unpack(zExtendLSB({1'b0, getHiddenBit(fl), fl.sfd})); Int#(TAdd#(TAdd#(TAdd#(e,1),TLog#(m)),ln)) shft = -signExtend(unpack(unbias(fl))) + fromInteger(valueOf(n)) - 2 - zeroExtend(unpack(pack(frac))); @@ -3354,7 +3355,12 @@ instance FixedFloatCVT#(FloatingPoint#(e,m),Int#(n)) exc.invalid_op = True; // overflow signals invalid op end else if (shft > fromInteger(valueOf(n))) begin - out = 0; + if (rmode == Rnd_Minus_Inf && fl.sign) + out = -1; + else if (rmode == Rnd_Plus_Inf && !fl.sign) + out = 1; + else + out = 0; exc.inexact = True; end else begin @@ -3496,8 +3502,6 @@ instance FixedFloatCVT#(FloatingPoint#(e,m), FixedPoint#(isize,fsize)) out = 0; end else begin - // todo: does this work for subnormal? - // needs to be large so bits aren't lost before rounding Int#(TAdd#(n,TAdd#(m,2))) sfd = fl.sign ? -unpack(zExtendLSB({1'b0, getHiddenBit(fl), fl.sfd})) : unpack(zExtendLSB({1'b0, getHiddenBit(fl), fl.sfd})); Int#(TAdd#(TAdd#(TAdd#(e,1),TLog#(m)),ln)) shft = -signExtend(unpack(unbias(fl))) + fromInteger(valueOf(n)) - 2 - zeroExtend(unpack(pack(frac))); @@ -3547,7 +3551,12 @@ instance FixedFloatCVT#(FloatingPoint#(e,m), FixedPoint#(isize,fsize)) exc.invalid_op = True; // overflow signals invalid op end else if (shft > fromInteger(valueOf(n))) begin - out = 0; + if (rmode == Rnd_Minus_Inf && fl.sign) + out = -1; + else if (rmode == Rnd_Plus_Inf && !fl.sign) + out = 1; + else + out = 0; exc.inexact = True; end else begin diff --git a/testsuite/bsc.lib/FloatingPoint/FloatTest.exp b/testsuite/bsc.lib/FloatingPoint/FloatTest.exp index f072639d4..5a31c5db5 100644 --- a/testsuite/bsc.lib/FloatingPoint/FloatTest.exp +++ b/testsuite/bsc.lib/FloatingPoint/FloatTest.exp @@ -3,3 +3,9 @@ test_c_veri_bsv_modules_options FloatTest {} {+RTS -K13M -RTS} # Test that aggressive condition lifting isn't needed for correctness test_c_veri_bsv_modules_options Float_Divide_TestConds {} {-no-aggressive-conditions} test_c_veri_bsv_modules_options Float_SquareRoot_TestConds {} {-no-aggressive-conditions} + +# Test for vFloatToFixed in the FixedFloatCVT typeclass +# with various round modes, including subnormal/denormalized numbers +# (GitHub issue #489) +# Note that this only tests the instance for FixedPoint, not Int or UInt +test_c_veri_bsv FloatToFixed_RoundMode diff --git a/testsuite/bsc.lib/FloatingPoint/FloatToFixed_RoundMode.bsv b/testsuite/bsc.lib/FloatingPoint/FloatToFixed_RoundMode.bsv new file mode 100644 index 000000000..fb762af22 --- /dev/null +++ b/testsuite/bsc.lib/FloatingPoint/FloatToFixed_RoundMode.bsv @@ -0,0 +1,180 @@ +import FixedPoint::*; +import FloatingPoint::*; +import Vector::*; +import GetPut::*; +import ClientServer::*; +import StmtFSM::*; + +(* synthesize *) +module sysFloatToFixed_RoundMode(); + + // Use single-precision parameters + Integer e_size = 8; + Integer m_size = 23; + Integer isize_val = 32; // 32 integer bits + Integer fsize_val = 0; // 0 fractional bits (just integer) + Integer ln_val = 0; // No fractional shift + + let nan = unpack(32'b01111111110000000000000000000000); + + let inf = unpack(32'b01111111100000000000000000000000); + + let neginf = unpack(32'b11111111100000000000000000000000); + + let zero = unpack(32'b00000000000000000000000000000000); + + let quarter = unpack(32'b00111110100000000000000000000000); + + let half = unpack(32'b00111111000000000000000000000000); + + let one = unpack(32'b00111111100000000000000000000000); + + let one_and_half = unpack(32'b00111111110000000000000000000000); + + let neg_denorm = unpack(32'b10000000000000000000000000000001); + + let pos_denorm = unpack(32'b00000000000000000000000000000001); + + let minus_one_and_half = unpack(32'b10111111110000000000000000000000); + + rule test; + $display("=== Testing NaN ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val1 = nan; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result1 = vFloatToFixed(5'b0, fp_val1, Rnd_Nearest_Even); + FixedPoint#(32,0) fx1 = tpl_1(result1); + $display("%0x", fx1.i); + + $display("=== Testing Inf ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val2 = inf; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result2 = vFloatToFixed(5'b0, fp_val2, Rnd_Nearest_Even); + FixedPoint#(32,0) fx2 = tpl_1(result2); + $display("%0x", fx2.i); + + $display("=== Testing -Inf ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val3 = neginf; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result3 = vFloatToFixed(5'b0, fp_val3, Rnd_Nearest_Even); + FixedPoint#(32,0) fx3 = tpl_1(result3); + $display("%0x", fx3.i); + + $display("=== Testing Zero ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val4 = zero; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result4 = vFloatToFixed(5'b0, fp_val4, Rnd_Nearest_Even); + FixedPoint#(32,0) fx4 = tpl_1(result4); + $display("%0x", fx4.i); + + $display("=== Testing Quarter ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val5 = quarter; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result5 = vFloatToFixed(5'b0, fp_val5, Rnd_Nearest_Even); + FixedPoint#(32,0) fx5 = tpl_1(result5); + $display("%0x", fx5.i); + + $display("=== Testing Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val6 = half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result6 = vFloatToFixed(5'b0, fp_val6, Rnd_Nearest_Even); + FixedPoint#(32,0) fx6 = tpl_1(result6); + $display("%0x", fx6.i); + + $display("=== Testing One ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val7 = one; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result7 = vFloatToFixed(5'b0, fp_val7, Rnd_Nearest_Even); + FixedPoint#(32,0) fx7 = tpl_1(result7); + $display("%0x", fx7.i); + + $display("=== Testing One and Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val8 = one_and_half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result8 = vFloatToFixed(5'b0, fp_val8, Rnd_Nearest_Even); + FixedPoint#(32,0) fx8 = tpl_1(result8); + $display("%0x", fx8.i); + + $display("=== Testing One ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val9 = one; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result9 = vFloatToFixed(5'b0, fp_val9, Rnd_Minus_Inf); + FixedPoint#(32,0) fx9 = tpl_1(result9); + $display("%0x", fx9.i); + + $display("=== Testing One and Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val10 = one_and_half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result10 = vFloatToFixed(5'b0, fp_val10, Rnd_Minus_Inf); + FixedPoint#(32,0) fx10 = tpl_1(result10); + $display("%0x", fx10.i); + + $display("=== Testing Negative Denormalized ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val11 = neg_denorm; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result11 = vFloatToFixed(5'b0, fp_val11, Rnd_Minus_Inf); + FixedPoint#(32,0) fx11 = tpl_1(result11); + $display("%0x", fx11.i); + + $display("=== Testing One ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val12 = one; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result12 = vFloatToFixed(5'b0, fp_val12, Rnd_Plus_Inf); + FixedPoint#(32,0) fx12 = tpl_1(result12); + $display("%0x", fx12.i); + + $display("=== Testing One and Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val13 = one_and_half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result13 = vFloatToFixed(5'b0, fp_val13, Rnd_Plus_Inf); + FixedPoint#(32,0) fx13 = tpl_1(result13); + $display("%0x", fx13.i); + + $display("=== Testing Postive Denormalized ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val14 = pos_denorm; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result14 = vFloatToFixed(5'b0, fp_val14, Rnd_Plus_Inf); + FixedPoint#(32,0) fx14 = tpl_1(result14); + $display("%0x", fx14.i); + + $display("=== Testing One ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val15 = one; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result15 = vFloatToFixed(5'b0, fp_val15, Rnd_Zero); + FixedPoint#(32,0) fx15 = tpl_1(result15); + $display("%0x", fx15.i); + + $display("=== Testing One and Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val16 = one_and_half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result16 = vFloatToFixed(5'b0, fp_val16, Rnd_Zero); + FixedPoint#(32,0) fx16 = tpl_1(result16); + $display("%0x", fx16.i); + + $display("=== Testing Minus One and Half ==="); + + // Convert to integer + FloatingPoint#(8,23) fp_val17 = minus_one_and_half; + Tuple2#(FixedPoint#(32,0), FloatingPoint::Exception) result17 = vFloatToFixed(5'b0, fp_val17, Rnd_Zero); + FixedPoint#(32,0) fx17 = tpl_1(result17); + $display("%0x", fx17.i); + + $finish; + endrule + +endmodule diff --git a/testsuite/bsc.lib/FloatingPoint/sysFloatToFixed_RoundMode.out.expected b/testsuite/bsc.lib/FloatingPoint/sysFloatToFixed_RoundMode.out.expected new file mode 100644 index 000000000..e176e6c74 --- /dev/null +++ b/testsuite/bsc.lib/FloatingPoint/sysFloatToFixed_RoundMode.out.expected @@ -0,0 +1,34 @@ +=== Testing NaN === +80000000 +=== Testing Inf === +7fffffff +=== Testing -Inf === +80000000 +=== Testing Zero === +0 +=== Testing Quarter === +0 +=== Testing Half === +0 +=== Testing One === +1 +=== Testing One and Half === +2 +=== Testing One === +1 +=== Testing One and Half === +1 +=== Testing Negative Denormalized === +ffffffff +=== Testing One === +1 +=== Testing One and Half === +2 +=== Testing Postive Denormalized === +1 +=== Testing One === +1 +=== Testing One and Half === +1 +=== Testing Minus One and Half === +ffffffff From c1348cb6d9f14dd74f3b4dcde149c9396c572846 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 19:30:01 -0700 Subject: [PATCH 07/18] Use strict ByteString with offset indexing for binary deserialization MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit GitHub PR 936. * Use strict ByteString with offset indexing for binary deserialization Replace the [Word8] linked list in BinData's In monad state with a strict ByteString and integer offset. This eliminates millions of cons-cell allocations and pointer chases during .bo/.ba file reading. * Use toStrict to convert lazy ByteString in readBinFilePath B.toStrict is the canonical lazy-to-strict conversion and has been available since bytestring 0.10, which predates the oldest supported GHC (7.10.3). It replaces the equivalent BS.concat . B.toChunks. * Remove now-unused hash functions from Util * Use indexMaybe in BinData.getB indexMaybe needs bytestring >= 0.11, which ships with every GHC in the CI matrix (floor 9.6.7, plus 9.8/9.10/9.12/9.14), so it is safe within the project's tested support range. It replaces the explicit bounds check and the partial BS.index with a single total lookup — exactly one bounds check per byte and no partial-function call. * Split Bin Flags serialization into NOINLINE chunks With the strict state-passing In monad, GHC's simplifier blows up on the single 135-step writeBytes/readBytes chains in the Bin Flags instance: GenABin.hs alone needed ~15.9 GB of heap at -O2 with GHC 9.6.7 (~14.2 GB with GHC 9.4.7) and panics with heap overflow at the CI build's -M5G cap, as well as at the Makefile's default -M4G. Splitting the chains into NOINLINE chunks of 15 fields bounds what the simplifier sees at once: GenABin.hs now compiles in ~0.9 GB peak RSS and 1:36 wall (GHC 9.6.7, -O2, x86-64 Linux). The .ba byte format is unchanged - the same fields are serialized in the same order. --- src/comp/ABinUtil.hs | 4 +- src/comp/BinData.hs | 51 +++++------ src/comp/FileIOUtil.hs | 15 +-- src/comp/GenABin.hs | 201 +++++++++++++++++++++++++++++------------ src/comp/GenBin.hs | 17 ++-- src/comp/Util.hs | 21 +---- src/comp/dumpba.hs | 4 +- src/comp/dumpbo.hs | 4 +- 8 files changed, 195 insertions(+), 122 deletions(-) diff --git a/src/comp/ABinUtil.hs b/src/comp/ABinUtil.hs index 6e9522c63..e28615f85 100644 --- a/src/comp/ABinUtil.hs +++ b/src/comp/ABinUtil.hs @@ -8,8 +8,8 @@ module ABinUtil ( import Data.List(nub, partition) import Data.Maybe(isJust, fromJust) -import Data.Word import Control.Monad(when) +import qualified Data.ByteString as BS import Control.Monad.Except(ExceptT, throwError) import Control.Monad.State(StateT, runStateT, lift, get, put) @@ -501,7 +501,7 @@ readAndCheckABinPathCatch errh be_verbose path backend mod_name errmsg = do Nothing -> bsError errh [errmsg] Just abi -> return abi -decodeABin :: ErrorHandle -> Maybe Backend -> String -> [Word8] -> +decodeABin :: ErrorHandle -> Maybe Backend -> String -> BS.ByteString -> Either [EMsg] ABin decodeABin errh backend filename contents = let (abi, _) = readABinFile errh filename contents diff --git a/src/comp/BinData.hs b/src/comp/BinData.hs index 81fcef9dc..e0487ece3 100644 --- a/src/comp/BinData.hs +++ b/src/comp/BinData.hs @@ -50,7 +50,7 @@ import IntLit import Undefined import Prim hiding(PrimArg(..)) -import Util(Hash, hashInit, nextHash, showHash) +import Util(Hash, hashInit, nextHashByte, showHash) import Data.List(sort, intercalate) import Control.Monad(replicateM, liftM, ap) @@ -59,6 +59,7 @@ import Data.Array.Unboxed import Data.Bits import Data.Word import GHC.Exts(IsList(..)) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as TE @@ -325,7 +326,7 @@ section s action = do { beginSection s; action; endSection } -- in addition to unconsumed bytes and an optional hash of -- consumed bytes. -data IS = IS BinTable [Byte] !(Maybe Hash) -- Integer +data IS = IS !BinTable !BS.ByteString !Int !(Maybe Hash) -- In monad is a state transformer type monad newtype In a = In (IS -> (a,IS)) @@ -347,16 +348,14 @@ getN :: Int -> In [Byte] getN n = replicateM n getB getB :: In Byte -getB = In $ \is -> consume_byte is - where consume_byte (IS _ [] _) = - internalError "BinData.getB: unexpected end of byte stream" - consume_byte (IS bc (b:bs) (Just h)) = - -- trace ((show n) ++ ": " ++ (showHex (ord b) "")) $ - let h' = nextHash h [b] - in seq h' $ (b,(IS bc bs (Just h'))) - consume_byte (IS bc (b:bs) Nothing) = - -- trace ((show n) ++ ": " ++ (showHex (ord b) "")) $ - (b,(IS bc bs Nothing)) +getB = In $ \(IS bc bs off mh) -> + case BS.indexMaybe bs off of + Nothing -> internalError "BinData.getB: unexpected end of byte stream" + Just b -> let !off' = off + 1 + in case mh of + Just h -> let !h' = nextHashByte h b + in (b, IS bc bs off' (Just h')) + Nothing -> (b, IS bc bs off' Nothing) -- get an Int value (between 0 and 255) getI :: In Int @@ -409,10 +408,10 @@ mkNewVal :: (BinTable -> (Table v)) -> (BinTable -> (Table v) -> BinTable) -> In (Int,v) mkNewVal get set = - In $ \(IS bt bs h) -> + In $ \(IS bt bs off h) -> let (Known n m) = get bt bt' = set bt (Known (n+1) m) - in ((n, undefined), (IS bt' bs h)) + in ((n, undefined), (IS bt' bs off h)) -- get the right table, add a mapping from the index to the value, -- and put back the updated table while returning () @@ -420,17 +419,17 @@ mkRecordVal ::(BinTable -> (Table v)) -> (BinTable -> (Table v) -> BinTable) -> (Int -> v -> In ()) mkRecordVal get set idx v = - In $ \(IS bt bs h) -> + In $ \(IS bt bs off h) -> let (Known n m) = get bt bt' = v `seq` set bt (Known n (M.insert idx v m)) - in ((), (IS bt' bs h)) + in ((), (IS bt' bs off h)) -- get the right table and look up the value for the given index mkLookupIdx ::(BinTable -> (Table v)) -> (Int -> In v) mkLookupIdx get idx = - In $ \is@(IS bt _ _) -> + In $ \is@(IS bt _ _ _) -> let (Known _ m) = get bt in case (M.lookup idx m) of (Just v) -> (v, is) @@ -1528,21 +1527,21 @@ runOut (Out xs _) = let bes = compress $ toList xs encode :: (Bin a) => a -> [Byte] encode x = runOut (toBin x) -runIn :: In a -> [Byte] -> Bool -> (a, [Byte], String) +runIn :: In a -> BS.ByteString -> Bool -> (a, Int, String) runIn (In f) bs do_hash = let h0 = if do_hash then (Just hashInit) else Nothing - (x,(IS _ bs' h)) = f (IS unknownTable bs h0) + (x,(IS _ _ off h)) = f (IS unknownTable bs 0 h0) hstr = maybe "" showHash h - in (x, bs', hstr) + in (x, off, hstr) -decode :: (Bin a) => [Byte] -> a -decode s = let (x, bs, _) = runIn fromBin s False - in if (null bs) +decode :: (Bin a) => BS.ByteString -> a +decode s = let (x, off, _) = runIn fromBin s False + in if off == BS.length s then x else internalError "BinData.decode: unused trailing bytes" -decodeWithHash :: (Bin a) => [Byte] -> (a,String) -decodeWithHash s = let (x, bs, hstr) = runIn fromBin s True - in if (null bs) +decodeWithHash :: (Bin a) => BS.ByteString -> (a,String) +decodeWithHash s = let (x, off, hstr) = runIn fromBin s True + in if off == BS.length s then (x, hstr) else internalError "BinData.decodeWithHash: unused trailing bytes" diff --git a/src/comp/FileIOUtil.hs b/src/comp/FileIOUtil.hs index 45f850a6b..7661f6a25 100644 --- a/src/comp/FileIOUtil.hs +++ b/src/comp/FileIOUtil.hs @@ -51,6 +51,7 @@ import Data.Word import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as TE import qualified Data.Text.Encoding.Error as TEE +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import Util(concatMapM, mapFst) @@ -83,9 +84,9 @@ readFilePath errh pos verb name path = readFilesPath' errh pos verb [name] path >>= mapM (decodeUtf8orError errh name) readBinFilePath :: ErrorHandle -> Position -> - Bool -> String -> [String] -> IO (Maybe ([Word8], String)) + Bool -> String -> [String] -> IO (Maybe (BS.ByteString, String)) readBinFilePath errh pos verb name path = - readFilesPath' errh pos verb [name] path >>= return . mapFst B.unpack + readFilesPath' errh pos verb [name] path >>= return . mapFst B.toStrict -- for this variant, the file name can have an absolute path readFilePathOrAbs :: ErrorHandle -> Position -> @@ -215,22 +216,22 @@ readFileCatch errh pos fname = do -- This returns whether the read was successful, -- for callers who will move on if the file is not available -readBinaryFileMaybe :: FilePath -> IO (Maybe [Word8]) +readBinaryFileMaybe :: FilePath -> IO (Maybe BS.ByteString) readBinaryFileMaybe fname = let - handler :: CE.IOException -> IO (Maybe [Word8]) + handler :: CE.IOException -> IO (Maybe BS.ByteString) handler ioe = return Nothing - rdFile = do file <- B.unpack <$> B.readFile fname + rdFile = do file <- BS.readFile fname return (Just file) in catchIO rdFile handler -- This produces an error if the read is unsuccessful, -- for callers which expect the file to be there -readBinaryFileCatch :: ErrorHandle -> Position -> FilePath -> IO [Word8] +readBinaryFileCatch :: ErrorHandle -> Position -> FilePath -> IO BS.ByteString readBinaryFileCatch errh pos fname = - catchIO (B.unpack <$> B.readFile fname) (fileReadError errh emptyContext pos fname) + catchIO (BS.readFile fname) (fileReadError errh emptyContext pos fname) -- If the file writing fails, a BSC error message is reported writeFileCatch :: ErrorHandle -> FilePath -> String -> IO () diff --git a/src/comp/GenABin.hs b/src/comp/GenABin.hs index 3e15ddd1a..269c47de1 100644 --- a/src/comp/GenABin.hs +++ b/src/comp/GenABin.hs @@ -36,16 +36,20 @@ import qualified Data.ByteString as B header :: [Byte] header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-ba-20260705-1" +headerBS :: B.ByteString +headerBS = B.pack header + genABinFile :: ErrorHandle -> String -> ABin -> IO () genABinFile errh fn abin = writeBinaryFileCatch errh fn (header ++ encode abin) -readABinFile :: ErrorHandle -> String -> [Byte] -> (ABin, String) +readABinFile :: ErrorHandle -> String -> B.ByteString -> (ABin, String) readABinFile errh nm s = - if take (length header) s == header - then (decode (drop (length header) s), "") - --then (decodeWithHash (drop (length header) s)) - else bsErrorUnsafe errh [(noPosition, EBinFileVerMismatch nm)] + let hlen = B.length headerBS + in if B.take hlen s == headerBS + then (decode (B.drop hlen s), "") + --then (decodeWithHash (B.drop hlen s)) + else bsErrorUnsafe errh [(noPosition, EBinFileVerMismatch nm)] -- ---------- -- Bin ABin @@ -558,61 +562,76 @@ instance Bin Flags where a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 a_120 a_121 a_122 a_123 a_124 a_125 a_126 a_127 a_128 a_129 a_130 a_131 a_132 a_133 a_134) = - do toBin a_000; toBin a_001; toBin a_002; toBin a_003; toBin a_004; - toBin a_005; toBin a_006; toBin a_007; toBin a_008; toBin a_009; - toBin a_010; toBin a_011; toBin a_012; toBin a_013; toBin a_014; - toBin a_015; toBin a_016; toBin a_017; toBin a_018; toBin a_019; - toBin a_020; toBin a_021; toBin a_022; toBin a_023; toBin a_024; - toBin a_025; toBin a_026; toBin a_027; toBin a_028; toBin a_029; - toBin a_030; toBin a_031; toBin a_032; toBin a_033; toBin a_034; - toBin a_035; toBin a_036; toBin a_037; toBin a_038; toBin a_039; - toBin a_040; toBin a_041; toBin a_042; toBin a_043; toBin a_044; - toBin a_045; toBin a_046; toBin a_047; toBin a_048; toBin a_049; - toBin a_050; toBin a_051; toBin a_052; toBin a_053; toBin a_054; - toBin a_055; toBin a_056; toBin a_057; toBin a_058; toBin a_059; - toBin a_060; toBin a_061; toBin a_062; toBin a_063; toBin a_064; - toBin a_065; toBin a_066; toBin a_067; toBin a_068; toBin a_069; - toBin a_070; toBin a_071; toBin a_072; toBin a_073; toBin a_074; - toBin a_075; toBin a_076; toBin a_077; toBin a_078; toBin a_079; - toBin a_080; toBin a_081; toBin a_082; toBin a_083; toBin a_084; - toBin a_085; toBin a_086; toBin a_087; toBin a_088; toBin a_089; - toBin a_090; toBin a_091; toBin a_092; toBin a_093; toBin a_094; - toBin a_095; toBin a_096; toBin a_097; toBin a_098; toBin a_099; - toBin a_100; toBin a_101; toBin a_102; toBin a_103; toBin a_104; - toBin a_105; toBin a_106; toBin a_107; toBin a_108; toBin a_109; - toBin a_110; toBin a_111; toBin a_112; toBin a_113; toBin a_114; - toBin a_115; toBin a_116; toBin a_117; toBin a_118; toBin a_119; - toBin a_120; toBin a_121; toBin a_122; toBin a_123; toBin a_124; - toBin a_125; toBin a_126; toBin a_127; toBin a_128; toBin a_129; - toBin a_130; toBin a_131; toBin a_132; toBin a_133; toBin a_134 + do wr_chunk0; wr_chunk1; wr_chunk2; wr_chunk3; wr_chunk4; + wr_chunk5; wr_chunk6; wr_chunk7; wr_chunk8 + where + -- The 135-field serialization is split into NOINLINE chunks so + -- that GHC optimizes bounded pieces: compiling it as a single + -- monadic chain needs more than 15GB of heap. + {-# NOINLINE wr_chunk0 #-} + wr_chunk0 = + do toBin a_000; toBin a_001; toBin a_002; toBin a_003; toBin a_004; + toBin a_005; toBin a_006; toBin a_007; toBin a_008; toBin a_009; + toBin a_010; toBin a_011; toBin a_012; toBin a_013; toBin a_014 + {-# NOINLINE wr_chunk1 #-} + wr_chunk1 = + do toBin a_015; toBin a_016; toBin a_017; toBin a_018; toBin a_019; + toBin a_020; toBin a_021; toBin a_022; toBin a_023; toBin a_024; + toBin a_025; toBin a_026; toBin a_027; toBin a_028; toBin a_029 + {-# NOINLINE wr_chunk2 #-} + wr_chunk2 = + do toBin a_030; toBin a_031; toBin a_032; toBin a_033; toBin a_034; + toBin a_035; toBin a_036; toBin a_037; toBin a_038; toBin a_039; + toBin a_040; toBin a_041; toBin a_042; toBin a_043; toBin a_044 + {-# NOINLINE wr_chunk3 #-} + wr_chunk3 = + do toBin a_045; toBin a_046; toBin a_047; toBin a_048; toBin a_049; + toBin a_050; toBin a_051; toBin a_052; toBin a_053; toBin a_054; + toBin a_055; toBin a_056; toBin a_057; toBin a_058; toBin a_059 + {-# NOINLINE wr_chunk4 #-} + wr_chunk4 = + do toBin a_060; toBin a_061; toBin a_062; toBin a_063; toBin a_064; + toBin a_065; toBin a_066; toBin a_067; toBin a_068; toBin a_069; + toBin a_070; toBin a_071; toBin a_072; toBin a_073; toBin a_074 + {-# NOINLINE wr_chunk5 #-} + wr_chunk5 = + do toBin a_075; toBin a_076; toBin a_077; toBin a_078; toBin a_079; + toBin a_080; toBin a_081; toBin a_082; toBin a_083; toBin a_084; + toBin a_085; toBin a_086; toBin a_087; toBin a_088; toBin a_089 + {-# NOINLINE wr_chunk6 #-} + wr_chunk6 = + do toBin a_090; toBin a_091; toBin a_092; toBin a_093; toBin a_094; + toBin a_095; toBin a_096; toBin a_097; toBin a_098; toBin a_099; + toBin a_100; toBin a_101; toBin a_102; toBin a_103; toBin a_104 + {-# NOINLINE wr_chunk7 #-} + wr_chunk7 = + do toBin a_105; toBin a_106; toBin a_107; toBin a_108; toBin a_109; + toBin a_110; toBin a_111; toBin a_112; toBin a_113; toBin a_114; + toBin a_115; toBin a_116; toBin a_117; toBin a_118; toBin a_119 + {-# NOINLINE wr_chunk8 #-} + wr_chunk8 = + do toBin a_120; toBin a_121; toBin a_122; toBin a_123; toBin a_124; + toBin a_125; toBin a_126; toBin a_127; toBin a_128; toBin a_129; + toBin a_130; toBin a_131; toBin a_132; toBin a_133; toBin a_134 readBytes = - do a_000 <- fromBin; a_001 <- fromBin; a_002 <- fromBin; a_003 <- fromBin; a_004 <- fromBin; - a_005 <- fromBin; a_006 <- fromBin; a_007 <- fromBin; a_008 <- fromBin; a_009 <- fromBin; - a_010 <- fromBin; a_011 <- fromBin; a_012 <- fromBin; a_013 <- fromBin; a_014 <- fromBin; - a_015 <- fromBin; a_016 <- fromBin; a_017 <- fromBin; a_018 <- fromBin; a_019 <- fromBin; - a_020 <- fromBin; a_021 <- fromBin; a_022 <- fromBin; a_023 <- fromBin; a_024 <- fromBin; - a_025 <- fromBin; a_026 <- fromBin; a_027 <- fromBin; a_028 <- fromBin; a_029 <- fromBin; - a_030 <- fromBin; a_031 <- fromBin; a_032 <- fromBin; a_033 <- fromBin; a_034 <- fromBin; - a_035 <- fromBin; a_036 <- fromBin; a_037 <- fromBin; a_038 <- fromBin; a_039 <- fromBin; - a_040 <- fromBin; a_041 <- fromBin; a_042 <- fromBin; a_043 <- fromBin; a_044 <- fromBin; - a_045 <- fromBin; a_046 <- fromBin; a_047 <- fromBin; a_048 <- fromBin; a_049 <- fromBin; - a_050 <- fromBin; a_051 <- fromBin; a_052 <- fromBin; a_053 <- fromBin; a_054 <- fromBin; - a_055 <- fromBin; a_056 <- fromBin; a_057 <- fromBin; a_058 <- fromBin; a_059 <- fromBin; - a_060 <- fromBin; a_061 <- fromBin; a_062 <- fromBin; a_063 <- fromBin; a_064 <- fromBin; - a_065 <- fromBin; a_066 <- fromBin; a_067 <- fromBin; a_068 <- fromBin; a_069 <- fromBin; - a_070 <- fromBin; a_071 <- fromBin; a_072 <- fromBin; a_073 <- fromBin; a_074 <- fromBin; - a_075 <- fromBin; a_076 <- fromBin; a_077 <- fromBin; a_078 <- fromBin; a_079 <- fromBin; - a_080 <- fromBin; a_081 <- fromBin; a_082 <- fromBin; a_083 <- fromBin; a_084 <- fromBin; - a_085 <- fromBin; a_086 <- fromBin; a_087 <- fromBin; a_088 <- fromBin; a_089 <- fromBin; - a_090 <- fromBin; a_091 <- fromBin; a_092 <- fromBin; a_093 <- fromBin; a_094 <- fromBin; - a_095 <- fromBin; a_096 <- fromBin; a_097 <- fromBin; a_098 <- fromBin; a_099 <- fromBin; - a_100 <- fromBin; a_101 <- fromBin; a_102 <- fromBin; a_103 <- fromBin; a_104 <- fromBin; - a_105 <- fromBin; a_106 <- fromBin; a_107 <- fromBin; a_108 <- fromBin; a_109 <- fromBin; - a_110 <- fromBin; a_111 <- fromBin; a_112 <- fromBin; a_113 <- fromBin; a_114 <- fromBin; - a_115 <- fromBin; a_116 <- fromBin; a_117 <- fromBin; a_118 <- fromBin; a_119 <- fromBin; - a_120 <- fromBin; a_121 <- fromBin; a_122 <- fromBin; a_123 <- fromBin; a_124 <- fromBin; - a_125 <- fromBin; a_126 <- fromBin; a_127 <- fromBin; a_128 <- fromBin; a_129 <- fromBin; - a_130 <- fromBin; a_131 <- fromBin; a_132 <- fromBin; a_133 <- fromBin; a_134 <- fromBin + do (a_000, a_001, a_002, a_003, a_004, a_005, a_006, a_007, + a_008, a_009, a_010, a_011, a_012, a_013, a_014) <- rd_chunk0 + (a_015, a_016, a_017, a_018, a_019, a_020, a_021, a_022, + a_023, a_024, a_025, a_026, a_027, a_028, a_029) <- rd_chunk1 + (a_030, a_031, a_032, a_033, a_034, a_035, a_036, a_037, + a_038, a_039, a_040, a_041, a_042, a_043, a_044) <- rd_chunk2 + (a_045, a_046, a_047, a_048, a_049, a_050, a_051, a_052, + a_053, a_054, a_055, a_056, a_057, a_058, a_059) <- rd_chunk3 + (a_060, a_061, a_062, a_063, a_064, a_065, a_066, a_067, + a_068, a_069, a_070, a_071, a_072, a_073, a_074) <- rd_chunk4 + (a_075, a_076, a_077, a_078, a_079, a_080, a_081, a_082, + a_083, a_084, a_085, a_086, a_087, a_088, a_089) <- rd_chunk5 + (a_090, a_091, a_092, a_093, a_094, a_095, a_096, a_097, + a_098, a_099, a_100, a_101, a_102, a_103, a_104) <- rd_chunk6 + (a_105, a_106, a_107, a_108, a_109, a_110, a_111, a_112, + a_113, a_114, a_115, a_116, a_117, a_118, a_119) <- rd_chunk7 + (a_120, a_121, a_122, a_123, a_124, a_125, a_126, a_127, + a_128, a_129, a_130, a_131, a_132, a_133, a_134) <- rd_chunk8 return (Flags a_000 a_001 a_002 a_003 a_004 a_005 a_006 a_007 a_008 a_009 a_010 a_011 a_012 a_013 a_014 a_015 a_016 a_017 a_018 a_019 @@ -628,6 +647,70 @@ instance Bin Flags where a_110 a_111 a_112 a_113 a_114 a_115 a_116 a_117 a_118 a_119 a_120 a_121 a_122 a_123 a_124 a_125 a_126 a_127 a_128 a_129 a_130 a_131 a_132 a_133 a_134) + where + {-# NOINLINE rd_chunk0 #-} + rd_chunk0 = + do a_000 <- fromBin; a_001 <- fromBin; a_002 <- fromBin; a_003 <- fromBin; a_004 <- fromBin; + a_005 <- fromBin; a_006 <- fromBin; a_007 <- fromBin; a_008 <- fromBin; a_009 <- fromBin; + a_010 <- fromBin; a_011 <- fromBin; a_012 <- fromBin; a_013 <- fromBin; a_014 <- fromBin + return (a_000, a_001, a_002, a_003, a_004, a_005, a_006, a_007, + a_008, a_009, a_010, a_011, a_012, a_013, a_014) + {-# NOINLINE rd_chunk1 #-} + rd_chunk1 = + do a_015 <- fromBin; a_016 <- fromBin; a_017 <- fromBin; a_018 <- fromBin; a_019 <- fromBin; + a_020 <- fromBin; a_021 <- fromBin; a_022 <- fromBin; a_023 <- fromBin; a_024 <- fromBin; + a_025 <- fromBin; a_026 <- fromBin; a_027 <- fromBin; a_028 <- fromBin; a_029 <- fromBin + return (a_015, a_016, a_017, a_018, a_019, a_020, a_021, a_022, + a_023, a_024, a_025, a_026, a_027, a_028, a_029) + {-# NOINLINE rd_chunk2 #-} + rd_chunk2 = + do a_030 <- fromBin; a_031 <- fromBin; a_032 <- fromBin; a_033 <- fromBin; a_034 <- fromBin; + a_035 <- fromBin; a_036 <- fromBin; a_037 <- fromBin; a_038 <- fromBin; a_039 <- fromBin; + a_040 <- fromBin; a_041 <- fromBin; a_042 <- fromBin; a_043 <- fromBin; a_044 <- fromBin + return (a_030, a_031, a_032, a_033, a_034, a_035, a_036, a_037, + a_038, a_039, a_040, a_041, a_042, a_043, a_044) + {-# NOINLINE rd_chunk3 #-} + rd_chunk3 = + do a_045 <- fromBin; a_046 <- fromBin; a_047 <- fromBin; a_048 <- fromBin; a_049 <- fromBin; + a_050 <- fromBin; a_051 <- fromBin; a_052 <- fromBin; a_053 <- fromBin; a_054 <- fromBin; + a_055 <- fromBin; a_056 <- fromBin; a_057 <- fromBin; a_058 <- fromBin; a_059 <- fromBin + return (a_045, a_046, a_047, a_048, a_049, a_050, a_051, a_052, + a_053, a_054, a_055, a_056, a_057, a_058, a_059) + {-# NOINLINE rd_chunk4 #-} + rd_chunk4 = + do a_060 <- fromBin; a_061 <- fromBin; a_062 <- fromBin; a_063 <- fromBin; a_064 <- fromBin; + a_065 <- fromBin; a_066 <- fromBin; a_067 <- fromBin; a_068 <- fromBin; a_069 <- fromBin; + a_070 <- fromBin; a_071 <- fromBin; a_072 <- fromBin; a_073 <- fromBin; a_074 <- fromBin + return (a_060, a_061, a_062, a_063, a_064, a_065, a_066, a_067, + a_068, a_069, a_070, a_071, a_072, a_073, a_074) + {-# NOINLINE rd_chunk5 #-} + rd_chunk5 = + do a_075 <- fromBin; a_076 <- fromBin; a_077 <- fromBin; a_078 <- fromBin; a_079 <- fromBin; + a_080 <- fromBin; a_081 <- fromBin; a_082 <- fromBin; a_083 <- fromBin; a_084 <- fromBin; + a_085 <- fromBin; a_086 <- fromBin; a_087 <- fromBin; a_088 <- fromBin; a_089 <- fromBin + return (a_075, a_076, a_077, a_078, a_079, a_080, a_081, a_082, + a_083, a_084, a_085, a_086, a_087, a_088, a_089) + {-# NOINLINE rd_chunk6 #-} + rd_chunk6 = + do a_090 <- fromBin; a_091 <- fromBin; a_092 <- fromBin; a_093 <- fromBin; a_094 <- fromBin; + a_095 <- fromBin; a_096 <- fromBin; a_097 <- fromBin; a_098 <- fromBin; a_099 <- fromBin; + a_100 <- fromBin; a_101 <- fromBin; a_102 <- fromBin; a_103 <- fromBin; a_104 <- fromBin + return (a_090, a_091, a_092, a_093, a_094, a_095, a_096, a_097, + a_098, a_099, a_100, a_101, a_102, a_103, a_104) + {-# NOINLINE rd_chunk7 #-} + rd_chunk7 = + do a_105 <- fromBin; a_106 <- fromBin; a_107 <- fromBin; a_108 <- fromBin; a_109 <- fromBin; + a_110 <- fromBin; a_111 <- fromBin; a_112 <- fromBin; a_113 <- fromBin; a_114 <- fromBin; + a_115 <- fromBin; a_116 <- fromBin; a_117 <- fromBin; a_118 <- fromBin; a_119 <- fromBin + return (a_105, a_106, a_107, a_108, a_109, a_110, a_111, a_112, + a_113, a_114, a_115, a_116, a_117, a_118, a_119) + {-# NOINLINE rd_chunk8 #-} + rd_chunk8 = + do a_120 <- fromBin; a_121 <- fromBin; a_122 <- fromBin; a_123 <- fromBin; a_124 <- fromBin; + a_125 <- fromBin; a_126 <- fromBin; a_127 <- fromBin; a_128 <- fromBin; a_129 <- fromBin; + a_130 <- fromBin; a_131 <- fromBin; a_132 <- fromBin; a_133 <- fromBin; a_134 <- fromBin + return (a_120, a_121, a_122, a_123, a_124, a_125, a_126, a_127, + a_128, a_129, a_130, a_131, a_132, a_133, a_134) -- ---------- diff --git a/src/comp/GenBin.hs b/src/comp/GenBin.hs index b2b0806f4..c83378c67 100644 --- a/src/comp/GenBin.hs +++ b/src/comp/GenBin.hs @@ -3,7 +3,6 @@ module GenBin(genBinFile, readBinFile) where import Control.Monad(when) -import Data.Word import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString as B @@ -29,19 +28,23 @@ doTrace = elem "-trace-genbin" progArgs header :: [Byte] header = B.unpack $ TE.encodeUtf8 $ T.pack "bsc-bo-20260705-1" +headerBS :: B.ByteString +headerBS = B.pack header + genBinFile :: ErrorHandle -> String -> CSignature -> CSignature -> IPackage a -> IO () genBinFile errh fn bi_sig bo_sig ipkg = writeBinaryFileCatch errh fn (header ++ encode (bi_sig, bo_sig, ipkg)) -readBinFile :: ErrorHandle -> String -> [Word8] -> +readBinFile :: ErrorHandle -> String -> B.ByteString -> IO (CSignature, CSignature, IPackage a, String) readBinFile errh nm s = - if take (length header) s == header - then let ((bi_sig, bo_sig, ipkg), hash) = - decodeWithHash $ drop (length header) s - in return (bi_sig, bo_sig, ipkg, hash) - else bsError errh [(noPosition, EBinFileVerMismatch nm)] + let hlen = B.length headerBS + in if B.take hlen s == headerBS + then let ((bi_sig, bo_sig, ipkg), hash) = + decodeWithHash $ B.drop hlen s + in return (bi_sig, bo_sig, ipkg, hash) + else bsError errh [(noPosition, EBinFileVerMismatch nm)] -- ---------- -- Bin CSignature diff --git a/src/comp/Util.hs b/src/comp/Util.hs index 73fbef6a6..1007455d0 100644 --- a/src/comp/Util.hs +++ b/src/comp/Util.hs @@ -4,7 +4,7 @@ module Util where import Data.Char(intToDigit) import Data.Word(Word8,Word32,Word64) import Data.Bits -import Data.List(sort, sortBy, group, groupBy, nubBy, union, foldl') +import Data.List(sort, sortBy, group, groupBy, nubBy, union) import Data.Bifunctor(first,second) import Control.Monad(foldM) import Debug.Trace(trace) @@ -606,25 +606,12 @@ hashInit = Hash 0 4000000063 -- showpair (x,y) = "(" ++ (showHex x ("," ++ (showHex y ")"))) -nextHash :: Hash -> [Word8] -> Hash -nextHash h s = foldl' f h s - where f :: Hash -> Word8 -> Hash - f (Hash x y) c = - let y' = (rotate x 5) + (toEnum (fromEnum c)) - x' = y + y' + 1442968193 - in Hash x' y' - -nextHash32 :: Hash -> Word32 -> Hash -nextHash32 (Hash x y) n = - let y' = (rotate x 20) + n +nextHashByte :: Hash -> Word8 -> Hash +nextHashByte (Hash x y) c = + let y' = (rotate x 5) + (toEnum (fromEnum c)) x' = y + y' + 1442968193 in Hash x' y' -nextHash64 :: Hash -> Word64 -> Hash -nextHash64 h n = - let (hi,lo) = n `quotRem` (2^(32::Int)) - in nextHash32 (nextHash32 h (fromIntegral lo)) (fromIntegral hi) - hashValue :: Hash -> Word64 hashValue (Hash x y) = ((fromIntegral x) `shiftL` 32) .|. (fromIntegral y) diff --git a/src/comp/dumpba.hs b/src/comp/dumpba.hs index 6a8d1c182..17f1550e0 100644 --- a/src/comp/dumpba.hs +++ b/src/comp/dumpba.hs @@ -7,7 +7,7 @@ import GenABin import PPrint import Error(initErrorHandle) import System.IO -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as BS main :: IO () main = do @@ -15,7 +15,7 @@ main = do as <- getArgs case as of [mi] -> do - file <- B.unpack <$> B.readFile mi + file <- BS.readFile mi let (abi, hash) = readABinFile errh mi file hSetEncoding stdout utf8 putStr (ppReadable abi) diff --git a/src/comp/dumpbo.hs b/src/comp/dumpbo.hs index 655b7f79f..eb5e24972 100644 --- a/src/comp/dumpbo.hs +++ b/src/comp/dumpbo.hs @@ -9,7 +9,7 @@ import GenBin import ISyntax import Error(initErrorHandle) import System.IO -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as BS main :: IO () main = do @@ -20,7 +20,7 @@ main = do [mi@(c:_)] | (c /= '-') -> return (False, mi) _ -> do putStr ("Usage: dumpbo [-bi] mod-id\n") exitWith (ExitFailure 1) - file <- B.unpack <$> B.readFile fname + file <- BS.readFile fname (bi_sig, bo_sig, ipkg, hash) <- readBinFile errh fname file hSetEncoding stdout utf8 if (isBI) From cd1fa92735972ffa81198176019035f1684b58ab Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 19:32:39 -0700 Subject: [PATCH 08/18] Internal evaluator type tracking fix for PrimStringSplit GitHub PR 954. * Add test for PrimStringSplit type correctness with -trace-eval-types * Compute PrimStringSplit result type directly instead of using resType resType uses dropArrows on the prim's type, which requires type normalization to see through ATFs. Construct the concrete type instead. * Test the Invalid arm of PrimStringSplit with an empty string The existing test only evaluated stringSplit on a non-empty string, covering the Valid result path of the evaluator fix. Add a register initialized from stringSplit "" so the Invalid (iMkInvalid) path is also forced at elaboration time under -trace-eval-types. --- src/comp/IExpand.hs | 7 ++++--- testsuite/bsc.codegen/strings/StringSplitTypes.bs | 14 ++++++++++++++ testsuite/bsc.codegen/strings/strings.exp | 6 ++++++ 3 files changed, 24 insertions(+), 3 deletions(-) create mode 100644 testsuite/bsc.codegen/strings/StringSplitTypes.bs diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 21069b438..4cea006c9 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -3706,14 +3706,15 @@ conAp' _ prim@(ICPrim _ op) fe@(ICon prim_id _) [E e] | stringPrim op = PrimStringLength -> return $ pExpr $ iMkLitAt pos itInteger (genericLength s) PrimGetStringPosition -> return $ pExpr $ iMkPosition pos - PrimStringSplit -> + PrimStringSplit -> do + let pairType = itPair itChar itString case s of - [] -> return $ pExpr $ iMkInvalid resType + [] -> return $ pExpr $ iMkInvalid pairType (c:r) -> let e_c = iMkCharAt pos c e_r = iMkStringAt pos r e_pair = iMkPairAt pos itChar itString e_c e_r - in return $ pExpr $ iMkValid resType e_pair + in return $ pExpr $ iMkValid pairType e_pair PrimStringToChar -> case s of [c] -> return $ pExpr $ iMkCharAt pos c diff --git a/testsuite/bsc.codegen/strings/StringSplitTypes.bs b/testsuite/bsc.codegen/strings/StringSplitTypes.bs new file mode 100644 index 000000000..62b82b0c4 --- /dev/null +++ b/testsuite/bsc.codegen/strings/StringSplitTypes.bs @@ -0,0 +1,14 @@ +-- Test that PrimStringSplit produces correctly-typed results +-- when checked with -trace-eval-types + +package StringSplitTypes where + +{-# synthesize sysStringSplitTypes #-} +sysStringSplitTypes :: Module Empty +sysStringSplitTypes = module + -- non-empty string exercises the Valid result path + rg :: Reg Bool + rg <- mkReg (isJust (stringSplit "hello")) + -- empty string exercises the Invalid result path + rg2 :: Reg Bool + rg2 <- mkReg (isJust (stringSplit "")) diff --git a/testsuite/bsc.codegen/strings/strings.exp b/testsuite/bsc.codegen/strings/strings.exp index 75e68d6f5..f4ef09195 100644 --- a/testsuite/bsc.codegen/strings/strings.exp +++ b/testsuite/bsc.codegen/strings/strings.exp @@ -26,6 +26,12 @@ compare_file CharLiteralBad_Multiple.bsv.bsc-vcomp-out # Test non-error behavior test_veri_only_bsv StringCharFunctions +# Verify string prims produce correctly-typed results. +# The -trace-eval-types flag turns evaluator type mismatches into +# compile failures, so successful compilation is itself the check. +compile_verilog_pass StringCharFunctions.bsv {} {-trace-eval-types} +compile_verilog_pass StringSplitTypes.bs {} {-trace-eval-types} + # Test error conditions # head of empty string From 4eda94e060d19bce1f4affe0df6618103b60723d Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Tue, 30 Jun 2026 17:47:44 -0700 Subject: [PATCH 09/18] Canonicalize stack-moved declaration order in Bluesim codegen simCOpt moves block-local defs into their using function; the order came from the Id sort, which is hierarchy-dependent. Sort by base name. Co-Authored-By: Claude Opus 4.8 --- src/comp/SimCOpt.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/comp/SimCOpt.hs b/src/comp/SimCOpt.hs index 024c53d28..d752c61c7 100644 --- a/src/comp/SimCOpt.hs +++ b/src/comp/SimCOpt.hs @@ -13,8 +13,9 @@ import Util(mapSnd) import SimPrimitiveModules(isPrimitiveModule) import Data.Maybe(maybeToList) -import Data.List(find, intercalate) +import Data.List(find, intercalate, sortBy) import Data.List.Split(split, condense, oneOf) +import Data.Function(on) import qualified Data.Map as M import qualified Data.Set as S @@ -220,8 +221,12 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = _ -> internalError "SimCOpt.moveDefsOntoStack btype_lookup" moveDefs (Just sbid) fn = -- move within block let fname = sf_name fn + -- Sort by base name so the order doesn't depend on the Id sort + -- (which carries hierarchy-dependent qualifier/position info). + moved_aids = sortBy (compare `on` getIdBaseString) + (map snd (M.findWithDefault [] ((Just sbid),fname) move_map)) new_defs = [ SFSDef isPort (ty,aid) Nothing - | (_,aid) <- M.findWithDefault [] ((Just sbid),fname) move_map + | aid <- moved_aids , let ty = btype_lookup (sbid,aid) , let isPort = S.member (sbid,aid) port_set ] From 1839fe82c5b7e336305f35e5aa179c3a1a0ec740 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Tue, 30 Jun 2026 17:48:22 -0700 Subject: [PATCH 10/18] Canonicalize method-port order in Bluesim codegen The port list came from an AId-keyed map, whose Ord is run-dependent. Sort by base name. Co-Authored-By: Claude Opus 4.8 --- src/comp/SimMakeCBlocks.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index c6a8cd2ff..721772522 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -296,7 +296,10 @@ onePackageToBlock flags name_map full_meth_map ss pkg = meth_rets = [ (rt, n, vn) | (n, (_,_,(Just (rt,vn)),_,_)) <- M.toList meth_map ] - ports = meth_ens ++ meth_args ++ meth_rets + -- Sort by base name so the order doesn't depend on the AId map order + -- (AId's Ord follows run-dependent interned-FString order). + ports = sortBy (\(_,a,_) (_,b,_) -> compare (getIdBaseString a) (getIdBaseString b)) + (meth_ens ++ meth_args ++ meth_rets) -- ---------- -- clock domains From 2fb5260f03de9443bf60018ba64272f7956120a7 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Tue, 30 Jun 2026 17:48:35 -0700 Subject: [PATCH 11/18] Canonicalize rule/method body statement order in Bluesim codegen tsort breaks ties by the run-dependent AId Ord. Rank def nodes by id-name around the tsort so the statement order is stable. Co-Authored-By: Claude Opus 4.8 --- src/comp/SimMakeCBlocks.hs | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index 721772522..b655d19ca 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -1437,6 +1437,20 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = -- Convert the graph to the format expected by tsort. g_edges = M.toList g + -- tsort breaks ties by node Ord (for defs, the run-dependent AId Ord), + -- so rank def nodes by id-name before tsort and map back for a stable + -- order. (Actions keep their position; Left compare (getIdString a) (getIdString b)) g_def_ids) + [(0::Integer)..] + unrank_map = M.fromList [ (r,i) | (i,r) <- M.toList rank_map ] + encNode (Left i) = Left (fromJust (M.lookup i rank_map)) + encNode (Right n) = Right n + decNode (Left r) = Left (fromJust (M.lookup r unrank_map)) + decNode (Right n) = Right n + enc_edges = [ (encNode n, map encNode ns) | (n,ns) <- g_edges ] + -- ---------- -- convert a graph node back into a def/action -- and then to a SimCCFnStmt @@ -1509,17 +1523,17 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = -- the lower valued nodes first. Thus, we have chosen the node -- representation to put Defs first, followed by Actions in the -- order that they were give by the user.) - case (tsort g_edges) of + case (tsort enc_edges) of Left iss -> let -- lookup def and action nodes lookupFn = either (Left . getDef) (Right . getAct) - xss = map (map lookupFn) iss + xss = map (map (lookupFn . decNode)) iss in internalError ("tsortActionsAndDefs: cyclic: " ++ ppReadable (modId, rId) ++ ppReadable xss) Right is -> let -- lookup def and action nodes - xs = map (either (Left . getDef) (Right . getAct)) is + xs = map ((either (Left . getDef) (Right . getAct)) . decNode) is -- group by reset conditions grouped = groupRsts xs in -- declare the local temporaries From c04e746b820789b12b2421a43daccf108530ffdf Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Tue, 30 Jun 2026 17:48:45 -0700 Subject: [PATCH 12/18] Canonicalize member-def order in Bluesim codegen The member defs were ordered by an AId-keyed map, whose Ord is run-dependent. Sort by base name. Co-Authored-By: Claude Opus 4.8 --- src/comp/SimMakeCBlocks.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index b655d19ca..a89396c49 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -262,7 +262,10 @@ onePackageToBlock flags name_map full_meth_map ss pkg = -- ---------- -- public and private class defs (public defs are all defs needed -- to compute CAN_FIRE and WILL_FIRE signals. - all_defs = map cvtADef raw_defs + -- Sort by base name so the order doesn't depend on raw_defs' AId map + -- order (AId's Ord follows run-dependent interned-FString order). + all_defs = sortBy (\(_,i1) (_,i2) -> compare (getIdBaseString i1) (getIdBaseString i2)) + (map cvtADef raw_defs) cf_wf_ex = [ ASDef t i | (t,i) <- all_defs , (isFire i) From f974ce227d0365c8c2f5da8153775f3bb017db57 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Tue, 30 Jun 2026 23:01:48 -0700 Subject: [PATCH 13/18] Cleanups: O(n^2) nub -> Set dedup, sortBy -> sortOn in Bluesim codegen Co-Authored-By: Claude Opus 4.8 --- src/comp/SimCOpt.hs | 5 ++--- src/comp/SimMakeCBlocks.hs | 23 ++++++++++++++++------- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/comp/SimCOpt.hs b/src/comp/SimCOpt.hs index d752c61c7..4d532d8e4 100644 --- a/src/comp/SimCOpt.hs +++ b/src/comp/SimCOpt.hs @@ -13,9 +13,8 @@ import Util(mapSnd) import SimPrimitiveModules(isPrimitiveModule) import Data.Maybe(maybeToList) -import Data.List(find, intercalate, sortBy) +import Data.List(find, intercalate, sortOn) import Data.List.Split(split, condense, oneOf) -import Data.Function(on) import qualified Data.Map as M import qualified Data.Set as S @@ -223,7 +222,7 @@ moveDefsOntoStack flags instmodmap (blocks,scheds) = let fname = sf_name fn -- Sort by base name so the order doesn't depend on the Id sort -- (which carries hierarchy-dependent qualifier/position info). - moved_aids = sortBy (compare `on` getIdBaseString) + moved_aids = sortOn getIdBaseString (map snd (M.findWithDefault [] ((Just sbid),fname) move_map)) new_defs = [ SFSDef isPort (ty,aid) Nothing | aid <- moved_aids diff --git a/src/comp/SimMakeCBlocks.hs b/src/comp/SimMakeCBlocks.hs index a89396c49..8b2ab84fa 100644 --- a/src/comp/SimMakeCBlocks.hs +++ b/src/comp/SimMakeCBlocks.hs @@ -22,7 +22,7 @@ import SCC(tsort) import Util import Data.Maybe(mapMaybe, isJust, fromJust, fromMaybe, maybeToList) -import Data.List(partition, nub, union, find, sortBy, (\\)) +import Data.List(partition, nub, union, find, sortBy, sortOn, (\\)) import qualified Data.Map as M import qualified Data.Set as S @@ -264,8 +264,7 @@ onePackageToBlock flags name_map full_meth_map ss pkg = -- to compute CAN_FIRE and WILL_FIRE signals. -- Sort by base name so the order doesn't depend on raw_defs' AId map -- order (AId's Ord follows run-dependent interned-FString order). - all_defs = sortBy (\(_,i1) (_,i2) -> compare (getIdBaseString i1) (getIdBaseString i2)) - (map cvtADef raw_defs) + all_defs = sortOn (getIdBaseString . snd) (map cvtADef raw_defs) cf_wf_ex = [ ASDef t i | (t,i) <- all_defs , (isFire i) @@ -301,8 +300,7 @@ onePackageToBlock flags name_map full_meth_map ss pkg = ] -- Sort by base name so the order doesn't depend on the AId map order -- (AId's Ord follows run-dependent interned-FString order). - ports = sortBy (\(_,a,_) (_,b,_) -> compare (getIdBaseString a) (getIdBaseString b)) - (meth_ens ++ meth_args ++ meth_rets) + ports = sortOn (\(_,a,_) -> getIdBaseString a) (meth_ens ++ meth_args ++ meth_rets) -- ---------- -- clock domains @@ -1443,15 +1441,21 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = -- tsort breaks ties by node Ord (for defs, the run-dependent AId Ord), -- so rank def nodes by id-name before tsort and map back for a stable -- order. (Actions keep their position; Left compare (getIdString a) (getIdString b)) g_def_ids) + zip (sortOn getIdString g_def_ids) [(0::Integer)..] + unrank_map :: M.Map Integer AId unrank_map = M.fromList [ (r,i) | (i,r) <- M.toList rank_map ] + encNode :: Node -> EncNode encNode (Left i) = Left (fromJust (M.lookup i rank_map)) encNode (Right n) = Right n + decNode :: EncNode -> Node decNode (Left r) = Left (fromJust (M.lookup r unrank_map)) decNode (Right n) = Right n + enc_edges :: [EncEdge] enc_edges = [ (encNode n, map encNode ns) | (n,ns) <- g_edges ] -- ---------- @@ -1550,6 +1554,11 @@ tsortActionsAndDefs modId rId mmap ds acts reset_ids = type Node = Either AId Integer type Edge = (Node, [Node]) +-- A Node with its def id (the Left) replaced by that id's integer rank, +-- so tsort's Ord-based tie-breaking is stable rather than AId-order dependent. +type EncNode = Either Integer Integer +type EncEdge = (EncNode, [EncNode]) + -- ---------- -- Given the defs and a list of only the action method calls (ACall), From 8458d046d0214e1985b959228aa1575c26fe1c5f Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 20:56:58 -0700 Subject: [PATCH 14/18] Verilog: render one-port-per-net inout ports plainly GitHub PR 10001. When an Inout port does not need to be rendered in Verilog with the ".io(io)" module port syntax -- that is, when the port is not connected to other ports of the module -- use a simple port declaration. While the dot notation is part of the standard, some tools do not support it (like Verilator). If a module has multiple Inout ports that are connected, continue to use the dot syntax. The alternatives are no more portable: Verilator rejects port aliases, SystemVerilog alias and the V1995 tran primitive alike, and iverilog rejects alias too. However, when generating the dot syntax, BSC now uses a port name (".io(io)") rather than a submodule signal (".io(mod$INOUT)"). This eliminates the need for the "basicinout.pl" script, therefore the "-verilator-filter" tests are updated with a new script, as well as improved to also test for the order in which multiple scripts are applied. --- src/comp/AVerilog.hs | 58 ++++++++++++- .../bsc.verilog/filter/ImpArgConnect.bsv | 23 ----- .../bsc.verilog/filter/ImpArgConnect2.bsv | 23 ----- .../bsc.verilog/filter/ImpArgConnect3.bsv | 23 ----- .../bsc.verilog/filter/ImpArgConnect4.bsv | 23 ----- testsuite/bsc.verilog/filter/InoutStub.bsv | 26 ------ .../bsc.verilog/filter/RedoInoutConnect.bsv | 9 -- testsuite/bsc.verilog/filter/RenameTest.bsv | 8 ++ testsuite/bsc.verilog/filter/basicinout.pl | 84 ------------------- testsuite/bsc.verilog/filter/filter.exp | 52 +++++++----- .../filter/mkArgImpConnect.v.expected | 38 --------- .../filter/mkArgImpConnect3.v.expected | 38 --------- .../filter/mkImpArgConnect.v.expected | 41 --------- .../filter/mkImpArgConnect3.v.expected | 41 --------- .../filter/mkRedoInoutConnect.v.expected | 38 --------- .../filter/mkRenameTest.v.renamed.expected | 72 ++++++++++++++++ .../filter/mkRenameTest.v.renamed2.expected | 72 ++++++++++++++++ .../filter/mkRenameTest.v.renamed3.expected | 72 ++++++++++++++++ testsuite/bsc.verilog/filter/order.sed | 1 + testsuite/bsc.verilog/filter/renamefire.pl | 21 +++++ .../inout/mkArgImpConnect.v.expected | 2 +- .../inout/mkFourInoutBuses.v.expected | 14 ++-- .../inout/mkImpArgConnect.v.expected | 8 +- .../inout/mkTwoInoutBuses.v.expected | 14 ++-- util/scripts/basicinout.pl | 84 ------------------- 25 files changed, 351 insertions(+), 534 deletions(-) delete mode 100644 testsuite/bsc.verilog/filter/ImpArgConnect.bsv delete mode 100644 testsuite/bsc.verilog/filter/ImpArgConnect2.bsv delete mode 100644 testsuite/bsc.verilog/filter/ImpArgConnect3.bsv delete mode 100644 testsuite/bsc.verilog/filter/ImpArgConnect4.bsv delete mode 100644 testsuite/bsc.verilog/filter/InoutStub.bsv delete mode 100644 testsuite/bsc.verilog/filter/RedoInoutConnect.bsv create mode 100644 testsuite/bsc.verilog/filter/RenameTest.bsv delete mode 100755 testsuite/bsc.verilog/filter/basicinout.pl delete mode 100644 testsuite/bsc.verilog/filter/mkArgImpConnect.v.expected delete mode 100644 testsuite/bsc.verilog/filter/mkArgImpConnect3.v.expected delete mode 100644 testsuite/bsc.verilog/filter/mkImpArgConnect.v.expected delete mode 100644 testsuite/bsc.verilog/filter/mkImpArgConnect3.v.expected delete mode 100644 testsuite/bsc.verilog/filter/mkRedoInoutConnect.v.expected create mode 100644 testsuite/bsc.verilog/filter/mkRenameTest.v.renamed.expected create mode 100644 testsuite/bsc.verilog/filter/mkRenameTest.v.renamed2.expected create mode 100644 testsuite/bsc.verilog/filter/mkRenameTest.v.renamed3.expected create mode 100644 testsuite/bsc.verilog/filter/order.sed create mode 100755 testsuite/bsc.verilog/filter/renamefire.pl delete mode 100755 util/scripts/basicinout.pl diff --git a/src/comp/AVerilog.hs b/src/comp/AVerilog.hs index 67b713ebb..a0170123c 100644 --- a/src/comp/AVerilog.hs +++ b/src/comp/AVerilog.hs @@ -17,6 +17,7 @@ import Data.Maybe import System.IO.Unsafe import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.Generics as Generic import ListMap(lookupWithDefault) import Util @@ -58,7 +59,7 @@ import qualified GraphWrapper as G aVerilog :: ErrorHandle -> Flags -> [PProp] -> ASPackage -> ForeignFuncMap -> IO VProgram aVerilog errh flags pps aspack ffmap = - return (VProgram mods dpi_decls comments) + return (VProgram (map renameInoutPorts mods) dpi_decls comments) where vco = flagsToVco flags -- look for pass-through comments, taking care of \n @@ -738,6 +739,61 @@ mkVDeclsAndDefs vDef ds = -- ============================== -- Top-level inout handing +-- Rename one-port-per-net inout ports to plain named ports. bsc binds +-- each inout port of a generated module to its internal net with a +-- port expression in the module header -- ".iioo(x$INOUT)", or +-- ".arg(arg)" for a module argument -- a header form some tools +-- (notably Verilator) cannot parse. When the port is the only one on +-- its net the expression serves no purpose: rename the net to the port +-- name throughout the module and emit a plain port. Ports sharing a +-- net (shorted inouts) keep the expression form; Verilog has no +-- plain-port rendering for those. (A port whose name is already in +-- use elsewhere in the module is left in expression form; that should +-- not happen, but this pass must not capture.) +renameInoutPorts :: VModule -> VModule +renameInoutPorts vm = + let args = concatMap fst (vm_ports vm) + + -- how many inout ports sit on each net (VId equality is by + -- Verilog name, which is net identity) + net_count :: M.Map VId Int + net_count = M.fromListWith (+) + [ (i', 1) | VAInout _ (Just i') _ <- args ] + -- how often each identifier occurs anywhere in the module + id_count :: M.Map VId Int + id_count = M.fromListWith (+) + [ (v, 1) | v <- Generic.listify isVId vm ] + where isVId :: VId -> Bool + isVId _ = True + + renames :: M.Map VId VId + renames = M.fromList + [ (i', i) + | VAInout i (Just i') _ <- args + , M.lookup i' net_count == Just 1 + , i /= i' + -- the port name occurs only in its own header + -- expression, so adopting it cannot capture + , M.lookup i id_count == Just 1 ] + + subst :: VId -> VId + subst v = M.findWithDefault v v renames + + vm' = Generic.everywhere (Generic.mkT subst) vm + + -- drop the now-trivial expressions (".iioo(iioo)"), including + -- ports that were already 1:1 with a same-named net + net_count' :: M.Map VId Int + net_count' = M.fromListWith (+) + [ (i', 1) + | VAInout _ (Just i') _ + <- concatMap fst (vm_ports vm') ] + plain (VAInout i (Just i') r) + | i == i', M.lookup i' net_count' == Just 1 + = VAInout i Nothing r + plain a = a + in vm' { vm_ports = [ (map plain as, c) | (as, c) <- vm_ports vm' ] } + computeInouts :: M.Map AId AId -> ASPackage -> [(Id, AType, Id)] computeInouts inout_rewire_map aspack = let diff --git a/testsuite/bsc.verilog/filter/ImpArgConnect.bsv b/testsuite/bsc.verilog/filter/ImpArgConnect.bsv deleted file mode 100644 index 5d634fa43..000000000 --- a/testsuite/bsc.verilog/filter/ImpArgConnect.bsv +++ /dev/null @@ -1,23 +0,0 @@ -import Inout::*; -import Connectable::*; - -import InoutStub::*; - -(* synthesize *) -module mkImpArgConnect#(Inout#(Int#(5)) arg)(); - - InoutSrcStub a <- mkInoutStubSrc1; - - mkConnection(a.foo,arg); - -endmodule - - -(* synthesize *) -module mkArgImpConnect#(Inout#(Int#(5)) arg)(); - - InoutSrcStub b <- mkInoutStubSrc2; - - mkConnection(arg, b.foo); - -endmodule diff --git a/testsuite/bsc.verilog/filter/ImpArgConnect2.bsv b/testsuite/bsc.verilog/filter/ImpArgConnect2.bsv deleted file mode 100644 index 672b3749f..000000000 --- a/testsuite/bsc.verilog/filter/ImpArgConnect2.bsv +++ /dev/null @@ -1,23 +0,0 @@ -import Inout::*; -import Connectable::*; - -import InoutStub::*; - -(* synthesize *) -module mkImpArgConnect2#(Inout#(Int#(5)) arg)(); - - InoutSrcStub a <- mkInoutStubSrc1; - - mkConnection(a.foo,arg); - -endmodule - - -(* synthesize *) -module mkArgImpConnect2#(Inout#(Int#(5)) arg)(); - - InoutSrcStub b <- mkInoutStubSrc2; - - mkConnection(arg, b.foo); - -endmodule diff --git a/testsuite/bsc.verilog/filter/ImpArgConnect3.bsv b/testsuite/bsc.verilog/filter/ImpArgConnect3.bsv deleted file mode 100644 index 8a380e775..000000000 --- a/testsuite/bsc.verilog/filter/ImpArgConnect3.bsv +++ /dev/null @@ -1,23 +0,0 @@ -import Inout::*; -import Connectable::*; - -import InoutStub::*; - -(* synthesize *) -module mkImpArgConnect3#(Inout#(Int#(5)) arg)(); - - InoutSrcStub a <- mkInoutStubSrc1; - - mkConnection(a.foo,arg); - -endmodule - - -(* synthesize *) -module mkArgImpConnect3#(Inout#(Int#(5)) arg)(); - - InoutSrcStub b <- mkInoutStubSrc2; - - mkConnection(arg, b.foo); - -endmodule diff --git a/testsuite/bsc.verilog/filter/ImpArgConnect4.bsv b/testsuite/bsc.verilog/filter/ImpArgConnect4.bsv deleted file mode 100644 index 5d634fa43..000000000 --- a/testsuite/bsc.verilog/filter/ImpArgConnect4.bsv +++ /dev/null @@ -1,23 +0,0 @@ -import Inout::*; -import Connectable::*; - -import InoutStub::*; - -(* synthesize *) -module mkImpArgConnect#(Inout#(Int#(5)) arg)(); - - InoutSrcStub a <- mkInoutStubSrc1; - - mkConnection(a.foo,arg); - -endmodule - - -(* synthesize *) -module mkArgImpConnect#(Inout#(Int#(5)) arg)(); - - InoutSrcStub b <- mkInoutStubSrc2; - - mkConnection(arg, b.foo); - -endmodule diff --git a/testsuite/bsc.verilog/filter/InoutStub.bsv b/testsuite/bsc.verilog/filter/InoutStub.bsv deleted file mode 100644 index 75c6907e2..000000000 --- a/testsuite/bsc.verilog/filter/InoutStub.bsv +++ /dev/null @@ -1,26 +0,0 @@ -// Some inout stubs to test Verilog generation - -interface InoutSrcStub; - method Inout#(Int#(5)) foo; -endinterface - -import "BVI" InoutStubSrc1 = -module mkInoutStubSrc1(InoutSrcStub); - ifc_inout foo(FOO); - default_clock clk(); - default_reset rst(); -endmodule - -import "BVI" InoutStubSrc2 = -module mkInoutStubSrc2(InoutSrcStub); - ifc_inout foo(BAR); - default_clock clk(); - default_reset rst(); -endmodule - -import "BVI" InoutArgStub = -module mkInoutArgStub#(Inout#(Int#(5)) bar)(); - inout ARG = bar; - default_clock clk(); - default_reset rst(); -endmodule diff --git a/testsuite/bsc.verilog/filter/RedoInoutConnect.bsv b/testsuite/bsc.verilog/filter/RedoInoutConnect.bsv deleted file mode 100644 index 8691386d9..000000000 --- a/testsuite/bsc.verilog/filter/RedoInoutConnect.bsv +++ /dev/null @@ -1,9 +0,0 @@ -import Inout::*; -import Connectable::*; - -(* synthesize *) -module mkRedoInoutConnect#(Inout#(UInt#(32)) a, Inout#(UInt#(32)) b)(); - - mkConnection(a,b); - -endmodule diff --git a/testsuite/bsc.verilog/filter/RenameTest.bsv b/testsuite/bsc.verilog/filter/RenameTest.bsv new file mode 100644 index 000000000..0b0caa12f --- /dev/null +++ b/testsuite/bsc.verilog/filter/RenameTest.bsv @@ -0,0 +1,8 @@ +(* synthesize *) +module mkRenameTest(); + Reg#(UInt#(8)) count <- mkReg(0); + + rule increment (count < 100); + count <= count + 1; + endrule +endmodule diff --git a/testsuite/bsc.verilog/filter/basicinout.pl b/testsuite/bsc.verilog/filter/basicinout.pl deleted file mode 100755 index 08e1e010e..000000000 --- a/testsuite/bsc.verilog/filter/basicinout.pl +++ /dev/null @@ -1,84 +0,0 @@ -#!/usr/bin/perl -- -# -*-Perl-*- -################################################################################ -################################################################################ - -my %RENAME_PORTS = (); -my %SIGNALS = (); -my %PINS = (); - - -foreach my $outfile (@ARGV) { - # read the file - next unless open(FILE, $outfile); - my @lines = ; - close(FILE); - - # Locate inout signals - my $inmodule = 0; - my $showedassigns = 0; - my @newlines; - foreach my $line (@lines) { - if ($line =~ m/rename\:\s+(\S+)\=(\S+)/) { - $RENAME_PORTS{$1} = $2; - } elsif ($line =~ m/^\s*module\s*[a-zA-Z0-9_\$]+\s*\(\s*\.(\S+)\(([a-zA-Z0-9_\$]+)\)/) { - $inmodule = 1; - $SIGNALS{$2} = $1; - $PINS{$1} = $2; - $line =~ s/\.(\S+)\(([a-zA-Z0-9_\$]+)\)/$1/; - push @newlines, $line; - } elsif ($line =~ m/^\s*module\s+(\S+)\s*\(/) { - $inmodule = 1; - push @newlines, $line; - } elsif ($line =~ m/^\s*\.(\S+)\(([a-zA-Z0-9_\$]+)\)/ && $inmodule) { - $SIGNALS{$2} = $1; - $PINS{$1} = $2; - $line =~ s/\.(\S+)\(([a-zA-Z0-9_\$]+)\)/$1/; - push @newlines, $line; - } elsif ($line =~ m/\s*inout(.*?)\s*(\S+)\;/) { - my $signal = $2; - my $origsig = $2; - - if (exists $SIGNALS{$signal}) { - my $pin = $SIGNALS{$signal}; - $signal =~ s/\$/\\\$/g; - $line =~ s/$signal/$pin/; - } else { - print("Failed to locate signal=$signal in module port list (basicinout)!\nPlease report this error to the BSC developers, by opening a ticket\nin the issue database\: https\:\/\/github.com\/B-Lang-org\/bsc\/issues\n\n"); - die; - } - push @newlines, $line; - } elsif ($line =~ m/input/ && $inmodule) { - $inmodule = 0; - push @newlines, $line; - } elsif ($line =~ m/\.(\S+)\(([a-zA-Z0-9\$_]+)\)/) { - my $signal = $2; - if (exists $SIGNALS{$signal}) { - my $pin = $SIGNALS{$signal}; - $signal =~ s/\$/\\\$/g; - $line =~ s/$signal/$pin/; - } - push @newlines, $line; - } else { - push @newlines, $line; - } - } - - # Rename any signals that need renaming - my @renamed_lines; - foreach my $line (@newlines) { - foreach my $signal (keys %RENAME_PORTS) { - my $replacement = $RENAME_PORTS{$signal}; - if ($line =~ m/$signal/) { - $line =~ s/([A-Za-z0-9_\$]*$signal)/$replacement/g; - } - } - push @renamed_lines, $line; - } - - # write out the new version - open(OFILE, ">${outfile}") or die("Could not create output file: $!\n"); - print OFILE @renamed_lines; - close(OFILE); -} -1; diff --git a/testsuite/bsc.verilog/filter/filter.exp b/testsuite/bsc.verilog/filter/filter.exp index bd8b04424..99f5033c4 100644 --- a/testsuite/bsc.verilog/filter/filter.exp +++ b/testsuite/bsc.verilog/filter/filter.exp @@ -8,29 +8,35 @@ proc make_sed_cmd { cmd_file out_file_ext } { return $sed_cmd } -# Check verilog filter -- basicinout -set filter1 "./basicinout.pl" +# Check the -verilog-filter flag with a sample filter that renames +# identifiers: renamefire.pl shortens the -keep-fires rule-signal +# prefixes (CAN_FIRE_ -> CF_, WILL_FIRE_ -> WF_) in the generated .v. +set filter1 "./renamefire.pl" set filter2 [make_sed_cmd {simple.sed} {}] set filter3 [make_sed_cmd {doesnotexist.sed} {}] -compile_verilog_pass RedoInoutConnect.bsv "" [list -verilog-filter $filter1] -compare_verilog mkRedoInoutConnect.v - -compile_verilog_pass ImpArgConnect.bsv "" [list -verilog-filter $filter1] -compare_verilog mkImpArgConnect.v -compare_verilog mkArgImpConnect.v - - - -# this should not fail basicinout should be able to run twice. -compile_verilog_pass_bug ImpArgConnect2.bsv "" "basicinout Bug" [list -verilog-filter $filter1 -verilog-filter $filter1] - - -# Test for multiple script -compile_verilog_pass ImpArgConnect3.bsv "" [list -verilog-filter $filter1 -verilog-filter $filter2] -compare_verilog mkImpArgConnect3.v -compare_verilog mkArgImpConnect3.v - - -compile_verilog_fail ImpArgConnect4.bsv "" [list -verilog-filter $filter1 -verilog-filter $filter3] - +compile_verilog_pass RenameTest.bsv "" [list -keep-fires -verilog-filter $filter1] +compare_verilog mkRenameTest.v mkRenameTest.v.renamed.expected + +# the filter only renames identifiers it introduces no match for, so +# applying it twice gives the same result +erase RenameTest.bo +compile_verilog_pass RenameTest.bsv "" [list -keep-fires -verilog-filter $filter1 -verilog-filter $filter1] +compare_verilog mkRenameTest.v mkRenameTest.v.renamed.expected + +# multiple scripts compose in order (the sed renames CLK to CLOCK) +erase RenameTest.bo +compile_verilog_pass RenameTest.bsv "" [list -keep-fires -verilog-filter $filter1 -verilog-filter $filter2] +compare_verilog mkRenameTest.v mkRenameTest.v.renamed2.expected + +# ... and apply in command-line order: the second sed rewrites the WF_ +# prefix that the first filter introduces (WILL_FIRE_ -> WF_ -> W_F_); +# in the reverse order there would be no WF_ to rewrite yet +set filter4 [make_sed_cmd {order.sed} {}] +erase RenameTest.bo +compile_verilog_pass RenameTest.bsv "" [list -keep-fires -verilog-filter $filter1 -verilog-filter $filter4] +compare_verilog mkRenameTest.v mkRenameTest.v.renamed3.expected + +# a filter that fails (here, sed with a missing script) fails the compile +erase RenameTest.bo +compile_verilog_fail RenameTest.bsv "" [list -keep-fires -verilog-filter $filter1 -verilog-filter $filter3] diff --git a/testsuite/bsc.verilog/filter/mkArgImpConnect.v.expected b/testsuite/bsc.verilog/filter/mkArgImpConnect.v.expected deleted file mode 100644 index cf3f6a84d..000000000 --- a/testsuite/bsc.verilog/filter/mkArgImpConnect.v.expected +++ /dev/null @@ -1,38 +0,0 @@ -// -// Generated by Bluespec Compiler -// -// -// Ports: -// Name I/O size props -// CLK I 1 unused -// RST_N I 1 unused -// arg IO 5 inout -// -// No combinational paths from inputs to outputs -// -// - -`ifdef BSV_ASSIGNMENT_DELAY -`else - `define BSV_ASSIGNMENT_DELAY -`endif - -`ifdef BSV_POSITIVE_RESET - `define BSV_RESET_VALUE 1'b1 - `define BSV_RESET_EDGE posedge -`else - `define BSV_RESET_VALUE 1'b0 - `define BSV_RESET_EDGE negedge -`endif - -module mkArgImpConnect(CLK, - RST_N, - arg); - input CLK; - input RST_N; - inout [4 : 0] arg; - - // submodule b - InoutStubSrc2 b(.BAR(arg)); -endmodule // mkArgImpConnect - diff --git a/testsuite/bsc.verilog/filter/mkArgImpConnect3.v.expected b/testsuite/bsc.verilog/filter/mkArgImpConnect3.v.expected deleted file mode 100644 index 83588c34b..000000000 --- a/testsuite/bsc.verilog/filter/mkArgImpConnect3.v.expected +++ /dev/null @@ -1,38 +0,0 @@ -// -// Generated by Bluespec Compiler -// -// -// Ports: -// Name I/O size props -// CLOCK I 1 unused -// RST_N I 1 unused -// arg IO 5 inout -// -// No combinational paths from inputs to outputs -// -// - -`ifdef BSV_ASSIGNMENT_DELAY -`else - `define BSV_ASSIGNMENT_DELAY -`endif - -`ifdef BSV_POSITIVE_RESET - `define BSV_RESET_VALUE 1'b1 - `define BSV_RESET_EDGE posedge -`else - `define BSV_RESET_VALUE 1'b0 - `define BSV_RESET_EDGE negedge -`endif - -module mkArgImpConnect3(CLOCK, - RST_N, - arg); - input CLOCK; - input RST_N; - inout [4 : 0] arg; - - // submodule b - InoutStubSrc2 b(.BAR(arg)); -endmodule // mkArgImpConnect3 - diff --git a/testsuite/bsc.verilog/filter/mkImpArgConnect.v.expected b/testsuite/bsc.verilog/filter/mkImpArgConnect.v.expected deleted file mode 100644 index c8070ebb7..000000000 --- a/testsuite/bsc.verilog/filter/mkImpArgConnect.v.expected +++ /dev/null @@ -1,41 +0,0 @@ -// -// Generated by Bluespec Compiler -// -// -// Ports: -// Name I/O size props -// CLK I 1 unused -// RST_N I 1 unused -// arg IO 5 inout -// -// No combinational paths from inputs to outputs -// -// - -`ifdef BSV_ASSIGNMENT_DELAY -`else - `define BSV_ASSIGNMENT_DELAY -`endif - -`ifdef BSV_POSITIVE_RESET - `define BSV_RESET_VALUE 1'b1 - `define BSV_RESET_EDGE posedge -`else - `define BSV_RESET_VALUE 1'b0 - `define BSV_RESET_EDGE negedge -`endif - -module mkImpArgConnect(CLK, - RST_N, - arg); - input CLK; - input RST_N; - inout [4 : 0] arg; - - // ports of submodule a - wire [4 : 0] a$FOO; - - // submodule a - InoutStubSrc1 a(.FOO(arg)); -endmodule // mkImpArgConnect - diff --git a/testsuite/bsc.verilog/filter/mkImpArgConnect3.v.expected b/testsuite/bsc.verilog/filter/mkImpArgConnect3.v.expected deleted file mode 100644 index 9484b2da3..000000000 --- a/testsuite/bsc.verilog/filter/mkImpArgConnect3.v.expected +++ /dev/null @@ -1,41 +0,0 @@ -// -// Generated by Bluespec Compiler -// -// -// Ports: -// Name I/O size props -// CLOCK I 1 unused -// RST_N I 1 unused -// arg IO 5 inout -// -// No combinational paths from inputs to outputs -// -// - -`ifdef BSV_ASSIGNMENT_DELAY -`else - `define BSV_ASSIGNMENT_DELAY -`endif - -`ifdef BSV_POSITIVE_RESET - `define BSV_RESET_VALUE 1'b1 - `define BSV_RESET_EDGE posedge -`else - `define BSV_RESET_VALUE 1'b0 - `define BSV_RESET_EDGE negedge -`endif - -module mkImpArgConnect3(CLOCK, - RST_N, - arg); - input CLOCK; - input RST_N; - inout [4 : 0] arg; - - // ports of submodule a - wire [4 : 0] a$FOO; - - // submodule a - InoutStubSrc1 a(.FOO(arg)); -endmodule // mkImpArgConnect3 - diff --git a/testsuite/bsc.verilog/filter/mkRedoInoutConnect.v.expected b/testsuite/bsc.verilog/filter/mkRedoInoutConnect.v.expected deleted file mode 100644 index a16716efb..000000000 --- a/testsuite/bsc.verilog/filter/mkRedoInoutConnect.v.expected +++ /dev/null @@ -1,38 +0,0 @@ -// -// Generated by Bluespec Compiler -// -// -// Ports: -// Name I/O size props -// CLK I 1 unused -// RST_N I 1 unused -// a IO 32 inout -// b IO 32 inout -// -// No combinational paths from inputs to outputs -// -// - -`ifdef BSV_ASSIGNMENT_DELAY -`else - `define BSV_ASSIGNMENT_DELAY -`endif - -`ifdef BSV_POSITIVE_RESET - `define BSV_RESET_VALUE 1'b1 - `define BSV_RESET_EDGE posedge -`else - `define BSV_RESET_VALUE 1'b0 - `define BSV_RESET_EDGE negedge -`endif - -module mkRedoInoutConnect(CLK, - RST_N, - a, - b); - input CLK; - input RST_N; - inout [31 : 0] b; - -endmodule // mkRedoInoutConnect - diff --git a/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed.expected b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed.expected new file mode 100644 index 000000000..562560ace --- /dev/null +++ b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed.expected @@ -0,0 +1,72 @@ +// +// Generated by Bluespec Compiler +// +// +// Ports: +// Name I/O size props +// CLK I 1 clock +// RST_N I 1 reset +// +// No combinational paths from inputs to outputs +// +// + +`ifdef BSV_ASSIGNMENT_DELAY +`else + `define BSV_ASSIGNMENT_DELAY +`endif + +`ifdef BSV_POSITIVE_RESET + `define BSV_RESET_VALUE 1'b1 + `define BSV_RESET_EDGE posedge +`else + `define BSV_RESET_VALUE 1'b0 + `define BSV_RESET_EDGE negedge +`endif + +module mkRenameTest(CLK, + RST_N); + input CLK; + input RST_N; + + // register count + reg [7 : 0] count; + wire [7 : 0] count$D_IN; + wire count$EN; + + // rule scheduling signals + wire CF_RL_increment, WF_RL_increment; + + // rule RL_increment + assign CF_RL_increment = count < 8'd100 ; + assign WF_RL_increment = CF_RL_increment ; + + // register count + assign count$D_IN = count + 8'd1 ; + assign count$EN = CF_RL_increment ; + + // handling of inlined registers + + always@(posedge CLK) + begin + if (RST_N == `BSV_RESET_VALUE) + begin + count <= `BSV_ASSIGNMENT_DELAY 8'd0; + end + else + begin + if (count$EN) count <= `BSV_ASSIGNMENT_DELAY count$D_IN; + end + end + + // synopsys translate_off + `ifdef BSV_NO_INITIAL_BLOCKS + `else // not BSV_NO_INITIAL_BLOCKS + initial + begin + count = 8'hAA; + end + `endif // BSV_NO_INITIAL_BLOCKS + // synopsys translate_on +endmodule // mkRenameTest + diff --git a/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed2.expected b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed2.expected new file mode 100644 index 000000000..18928c4f2 --- /dev/null +++ b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed2.expected @@ -0,0 +1,72 @@ +// +// Generated by Bluespec Compiler +// +// +// Ports: +// Name I/O size props +// CLOCK I 1 clock +// RST_N I 1 reset +// +// No combinational paths from inputs to outputs +// +// + +`ifdef BSV_ASSIGNMENT_DELAY +`else + `define BSV_ASSIGNMENT_DELAY +`endif + +`ifdef BSV_POSITIVE_RESET + `define BSV_RESET_VALUE 1'b1 + `define BSV_RESET_EDGE posedge +`else + `define BSV_RESET_VALUE 1'b0 + `define BSV_RESET_EDGE negedge +`endif + +module mkRenameTest(CLOCK, + RST_N); + input CLOCK; + input RST_N; + + // register count + reg [7 : 0] count; + wire [7 : 0] count$D_IN; + wire count$EN; + + // rule scheduling signals + wire CF_RL_increment, WF_RL_increment; + + // rule RL_increment + assign CF_RL_increment = count < 8'd100 ; + assign WF_RL_increment = CF_RL_increment ; + + // register count + assign count$D_IN = count + 8'd1 ; + assign count$EN = CF_RL_increment ; + + // handling of inlined registers + + always@(posedge CLOCK) + begin + if (RST_N == `BSV_RESET_VALUE) + begin + count <= `BSV_ASSIGNMENT_DELAY 8'd0; + end + else + begin + if (count$EN) count <= `BSV_ASSIGNMENT_DELAY count$D_IN; + end + end + + // synopsys translate_off + `ifdef BSV_NO_INITIAL_BLOCKS + `else // not BSV_NO_INITIAL_BLOCKS + initial + begin + count = 8'hAA; + end + `endif // BSV_NO_INITIAL_BLOCKS + // synopsys translate_on +endmodule // mkRenameTest + diff --git a/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed3.expected b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed3.expected new file mode 100644 index 000000000..c86cbaf87 --- /dev/null +++ b/testsuite/bsc.verilog/filter/mkRenameTest.v.renamed3.expected @@ -0,0 +1,72 @@ +// +// Generated by Bluespec Compiler +// +// +// Ports: +// Name I/O size props +// CLK I 1 clock +// RST_N I 1 reset +// +// No combinational paths from inputs to outputs +// +// + +`ifdef BSV_ASSIGNMENT_DELAY +`else + `define BSV_ASSIGNMENT_DELAY +`endif + +`ifdef BSV_POSITIVE_RESET + `define BSV_RESET_VALUE 1'b1 + `define BSV_RESET_EDGE posedge +`else + `define BSV_RESET_VALUE 1'b0 + `define BSV_RESET_EDGE negedge +`endif + +module mkRenameTest(CLK, + RST_N); + input CLK; + input RST_N; + + // register count + reg [7 : 0] count; + wire [7 : 0] count$D_IN; + wire count$EN; + + // rule scheduling signals + wire CF_RL_increment, W_F_RL_increment; + + // rule RL_increment + assign CF_RL_increment = count < 8'd100 ; + assign W_F_RL_increment = CF_RL_increment ; + + // register count + assign count$D_IN = count + 8'd1 ; + assign count$EN = CF_RL_increment ; + + // handling of inlined registers + + always@(posedge CLK) + begin + if (RST_N == `BSV_RESET_VALUE) + begin + count <= `BSV_ASSIGNMENT_DELAY 8'd0; + end + else + begin + if (count$EN) count <= `BSV_ASSIGNMENT_DELAY count$D_IN; + end + end + + // synopsys translate_off + `ifdef BSV_NO_INITIAL_BLOCKS + `else // not BSV_NO_INITIAL_BLOCKS + initial + begin + count = 8'hAA; + end + `endif // BSV_NO_INITIAL_BLOCKS + // synopsys translate_on +endmodule // mkRenameTest + diff --git a/testsuite/bsc.verilog/filter/order.sed b/testsuite/bsc.verilog/filter/order.sed new file mode 100644 index 000000000..280950e0f --- /dev/null +++ b/testsuite/bsc.verilog/filter/order.sed @@ -0,0 +1 @@ +s/WF_/W_F_/g diff --git a/testsuite/bsc.verilog/filter/renamefire.pl b/testsuite/bsc.verilog/filter/renamefire.pl new file mode 100755 index 000000000..b3a4cd9a7 --- /dev/null +++ b/testsuite/bsc.verilog/filter/renamefire.pl @@ -0,0 +1,21 @@ +#!/usr/bin/perl -- +# -*-Perl-*- +# A sample -verilog-filter: shorten BSC's -keep-fires rule-signal +# prefixes (CAN_FIRE_ -> CF_, WILL_FIRE_ -> WF_) in the generated +# Verilog. bsc invokes the filter with the generated file as its +# argument, and the filter rewrites the file in place. + +foreach my $outfile (@ARGV) { + next unless open(FILE, $outfile); + my @lines = ; + close(FILE); + + foreach my $line (@lines) { + $line =~ s/\bCAN_FIRE_/CF_/g; + $line =~ s/\bWILL_FIRE_/WF_/g; + } + + next unless open(FILE, ">", $outfile); + print FILE @lines; + close(FILE); +} diff --git a/testsuite/bsc.verilog/inout/mkArgImpConnect.v.expected b/testsuite/bsc.verilog/inout/mkArgImpConnect.v.expected index 2994be70f..cf3f6a84d 100644 --- a/testsuite/bsc.verilog/inout/mkArgImpConnect.v.expected +++ b/testsuite/bsc.verilog/inout/mkArgImpConnect.v.expected @@ -27,7 +27,7 @@ module mkArgImpConnect(CLK, RST_N, - .arg(arg)); + arg); input CLK; input RST_N; inout [4 : 0] arg; diff --git a/testsuite/bsc.verilog/inout/mkFourInoutBuses.v.expected b/testsuite/bsc.verilog/inout/mkFourInoutBuses.v.expected index 43f2c614e..e0e3379ff 100644 --- a/testsuite/bsc.verilog/inout/mkFourInoutBuses.v.expected +++ b/testsuite/bsc.verilog/inout/mkFourInoutBuses.v.expected @@ -34,21 +34,21 @@ module mkFourInoutBuses(CLK, RST_N, .a(a), .b(a), - .c(o$FOO), + c, .d(d), .e(d), .f(d)); input CLK; input RST_N; inout [4 : 0] a; - inout [4 : 0] o$FOO; + inout [4 : 0] c; inout [4 : 0] d; // ports of submodule h wire [4 : 0] h$FOO; // ports of submodule o - wire [4 : 0] o$FOO; + wire [4 : 0] c; // submodule g InoutArgStub g(.ARG(d)); @@ -72,15 +72,15 @@ module mkFourInoutBuses(CLK, InoutArgStub m(.ARG(a)); // submodule n - InoutStubSrc1 n(.FOO(o$FOO)); + InoutStubSrc1 n(.FOO(c)); // submodule o - InoutStubSrc1 o(.FOO(o$FOO)); + InoutStubSrc1 o(.FOO(c)); // submodule p - InoutStubSrc1 p(.FOO(o$FOO)); + InoutStubSrc1 p(.FOO(c)); // submodule q - InoutArgStub q(.ARG(o$FOO)); + InoutArgStub q(.ARG(c)); endmodule // mkFourInoutBuses diff --git a/testsuite/bsc.verilog/inout/mkImpArgConnect.v.expected b/testsuite/bsc.verilog/inout/mkImpArgConnect.v.expected index 91f3ac9e4..363fe7083 100644 --- a/testsuite/bsc.verilog/inout/mkImpArgConnect.v.expected +++ b/testsuite/bsc.verilog/inout/mkImpArgConnect.v.expected @@ -27,15 +27,15 @@ module mkImpArgConnect(CLK, RST_N, - .arg(a$FOO)); + arg); input CLK; input RST_N; - inout [4 : 0] a$FOO; + inout [4 : 0] arg; // ports of submodule a - wire [4 : 0] a$FOO; + wire [4 : 0] arg; // submodule a - InoutStubSrc1 a(.FOO(a$FOO)); + InoutStubSrc1 a(.FOO(arg)); endmodule // mkImpArgConnect diff --git a/testsuite/bsc.verilog/inout/mkTwoInoutBuses.v.expected b/testsuite/bsc.verilog/inout/mkTwoInoutBuses.v.expected index 037428ff2..e54e5d88f 100644 --- a/testsuite/bsc.verilog/inout/mkTwoInoutBuses.v.expected +++ b/testsuite/bsc.verilog/inout/mkTwoInoutBuses.v.expected @@ -33,14 +33,14 @@ module mkTwoInoutBuses(CLK, .a(a), .b(a), .c(a), - .d(h$BAR)); + d); input CLK; input RST_N; inout [4 : 0] a; - inout [4 : 0] h$BAR; + inout [4 : 0] d; // ports of submodule h - wire [4 : 0] h$BAR; + wire [4 : 0] d; // submodule e InoutStubSrc1 e(.FOO(a)); @@ -49,16 +49,16 @@ module mkTwoInoutBuses(CLK, InoutStubSrc1 f(.FOO(a)); // submodule g - InoutStubSrc2 g(.BAR(h$BAR)); + InoutStubSrc2 g(.BAR(d)); // submodule h - InoutStubSrc2 h(.BAR(h$BAR)); + InoutStubSrc2 h(.BAR(d)); // submodule i - InoutArgStub i(.ARG(h$BAR)); + InoutArgStub i(.ARG(d)); // submodule j - InoutArgStub j(.ARG(h$BAR)); + InoutArgStub j(.ARG(d)); // submodule k InoutArgStub k(.ARG(a)); diff --git a/util/scripts/basicinout.pl b/util/scripts/basicinout.pl deleted file mode 100755 index 08e1e010e..000000000 --- a/util/scripts/basicinout.pl +++ /dev/null @@ -1,84 +0,0 @@ -#!/usr/bin/perl -- -# -*-Perl-*- -################################################################################ -################################################################################ - -my %RENAME_PORTS = (); -my %SIGNALS = (); -my %PINS = (); - - -foreach my $outfile (@ARGV) { - # read the file - next unless open(FILE, $outfile); - my @lines = ; - close(FILE); - - # Locate inout signals - my $inmodule = 0; - my $showedassigns = 0; - my @newlines; - foreach my $line (@lines) { - if ($line =~ m/rename\:\s+(\S+)\=(\S+)/) { - $RENAME_PORTS{$1} = $2; - } elsif ($line =~ m/^\s*module\s*[a-zA-Z0-9_\$]+\s*\(\s*\.(\S+)\(([a-zA-Z0-9_\$]+)\)/) { - $inmodule = 1; - $SIGNALS{$2} = $1; - $PINS{$1} = $2; - $line =~ s/\.(\S+)\(([a-zA-Z0-9_\$]+)\)/$1/; - push @newlines, $line; - } elsif ($line =~ m/^\s*module\s+(\S+)\s*\(/) { - $inmodule = 1; - push @newlines, $line; - } elsif ($line =~ m/^\s*\.(\S+)\(([a-zA-Z0-9_\$]+)\)/ && $inmodule) { - $SIGNALS{$2} = $1; - $PINS{$1} = $2; - $line =~ s/\.(\S+)\(([a-zA-Z0-9_\$]+)\)/$1/; - push @newlines, $line; - } elsif ($line =~ m/\s*inout(.*?)\s*(\S+)\;/) { - my $signal = $2; - my $origsig = $2; - - if (exists $SIGNALS{$signal}) { - my $pin = $SIGNALS{$signal}; - $signal =~ s/\$/\\\$/g; - $line =~ s/$signal/$pin/; - } else { - print("Failed to locate signal=$signal in module port list (basicinout)!\nPlease report this error to the BSC developers, by opening a ticket\nin the issue database\: https\:\/\/github.com\/B-Lang-org\/bsc\/issues\n\n"); - die; - } - push @newlines, $line; - } elsif ($line =~ m/input/ && $inmodule) { - $inmodule = 0; - push @newlines, $line; - } elsif ($line =~ m/\.(\S+)\(([a-zA-Z0-9\$_]+)\)/) { - my $signal = $2; - if (exists $SIGNALS{$signal}) { - my $pin = $SIGNALS{$signal}; - $signal =~ s/\$/\\\$/g; - $line =~ s/$signal/$pin/; - } - push @newlines, $line; - } else { - push @newlines, $line; - } - } - - # Rename any signals that need renaming - my @renamed_lines; - foreach my $line (@newlines) { - foreach my $signal (keys %RENAME_PORTS) { - my $replacement = $RENAME_PORTS{$signal}; - if ($line =~ m/$signal/) { - $line =~ s/([A-Za-z0-9_\$]*$signal)/$replacement/g; - } - } - push @renamed_lines, $line; - } - - # write out the new version - open(OFILE, ">${outfile}") or die("Could not create output file: $!\n"); - print OFILE @renamed_lines; - close(OFILE); -} -1; From 136f3386e980ab67cdff988018e47a663c9812a1 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Sat, 4 Jul 2026 23:36:02 -0700 Subject: [PATCH 15/18] evaluator: make the PrimBNot push O(cells) over shared conditionals Evaluating a dynamic PrimBNot pushes the negation through PrimIf structure so that constant leaves can fold. The push recursed into both branches of every PrimIf with no memoization -- its definition site carries the comment "XXX When the same heap ref appears twice, this does twice the work!" -- and its leaf handler re-heaped a fresh application per visit, so a negation over a SHARED conditional DAG performed work (and allocated heap) proportional to the number of root-to-leaf PATHS, exponential in the DAG's depth. Conditional-update pipelines build exactly such DAGs: K stages of conditional swaps over an N-element vector deepen the DAG by two if-levels per stage. The original bug-1490 design (VsortOriginal.bsv) has been documented as exhausting a 256M heap since the initial open-source release (see also github #659); the new BNotShared.bsv test is starker: 4,792 defs whose conditional DAG contains ~2^129 then/else paths -- a per-path push cannot terminate, while the memoized push compiles it in seconds with default flags. The push (new function pushBNot) memoizes its result per heap cell (heapBNots in the evaluator state, following the existing extractWires wire-set cache), heaps intermediate results so pushed output remains a DAG, guards against self-referential structure with a visited set, and starts from the WHNF argument so that re-dispatch through the evaluator can still collapse all-equal dynamic selects (their residual forms are returned inline, never frozen into cells). VsortOriginal.bsv now compiles within the standard heap limit, so its expected-failure entry is flipped to a positive test. Co-Authored-By: Claude Fable 5 --- src/comp/IExpand.hs | 121 +++++++++++++++++- src/comp/IExpandUtils.hs | 18 +++ .../bsc.bugs/bluespec_inc/b1490/b1490.exp | 10 +- .../bsc.evaluator/performance/BNotShared.bsv | 58 +++++++++ .../bsc.evaluator/performance/performance.exp | 7 + 5 files changed, 203 insertions(+), 11 deletions(-) create mode 100644 testsuite/bsc.evaluator/performance/BNotShared.bsv diff --git a/src/comp/IExpand.hs b/src/comp/IExpand.hs index 4cea006c9..1833179b8 100644 --- a/src/comp/IExpand.hs +++ b/src/comp/IExpand.hs @@ -3863,13 +3863,13 @@ conAp' _ (ICPrim _ op) fe@(ICon prim_id _) as | strictPrim op = do else case (op, as') of (PrimBNot, [E e]) | isDyn e -> - -- The iTransExpr catch-all will handle PrimIf but not arrays - let handler e' = - case (doPrimOp bestPosition op [] [e']) of - Just (Right e_res) -> return (pExpr e_res) - Just (Left errmsg) -> errG (bestPosition, errmsg) - Nothing -> evalAp "Prim PrimBNot" fe [E e'] - in addPredG p $ evalStaticOp e itBit1 handler + -- Push the negation through conditional structure with + -- per-heap-cell memoization (see pushBNot): pushing once + -- per PATH instead of once per cell is exponential in the + -- depth of a shared conditional DAG. The WHNF arg is used + -- (not the heaped form) so that re-dispatch through the + -- evaluator can collapse all-equal dynamic selects. + addPredG p $ pushBNot bestPosition fe e -- name primitives (PrimJoinNames, [E (ICon _ (ICName { iName = n1 })), E (ICon _ (ICName { iName = n2 }))]) -> @@ -4807,6 +4807,113 @@ doOr2 f as@[E e1, E e2] pe1@(P p1 ie1) = do _ -> bldAp' "PrimBOr" f [E e1, E ee2] -- e1 and ee2 have the implicit conditions doOr2 f as pe = internalError("IExpand.doOr : " ++ ppReadable f ++ ppReadable as ++ ppReadable pe) +-- Push PrimBNot through a (possibly shared) conditional DAG once per +-- heap CELL, not once per path: the per-cell result is cached +-- (heapBNots in the evaluator state, same pattern as the extractWires +-- cache), intermediate results are heaped so the pushed result is a +-- DAG rather than an inline tree, and leaves that do not fold are +-- rebuilt from their HEAPED form (no re-evaluation, no fresh cells). +-- +-- Predicates (implicit conditions, e.g. from FIFO methods in the +-- selected elements) are carried OUTSIDE the returned expression, the +-- way evalStaticOp' carries them (pIf on the branch preds): heaping a +-- constant-with-pred yields a REF, and refs defeat the structural +-- equality folding (improveIf/iTransExpr's "if c k k ==> k") that +-- static consumers -- e.g. the termination condition of an +-- Integer-indexed Prelude recursion -- depend on. Constant results +-- are therefore always delivered bare, with the cell's pred lifted +-- into the P (see "deliver"); only non-constant residuals are +-- returned as shared refs. Exception: a residual dyn-select is +-- returned INLINE and never heaped or cached (see the tail below). +pushBNot :: Position -> HExpr -> HExpr -> G PExpr +pushBNot pos fe e = pushBNot' pos fe S.empty e + +pushBNot' :: Position -> HExpr -> S.Set HeapPointer -> HExpr -> G PExpr +pushBNot' pos fe visited e = do + (ee, P pe ew) <- evalUH e + let mkey = case ee of + IRefT _ ptr _ -> Just ptr + _ -> Nothing + -- cycle guard (cf. extractWires' visited set): self-referential + -- structures (e.g. guard logic) leave the negation unpushed + case mkey of + Just k | k `S.member` visited -> + addPredG pe $ bldAp' "Prim PrimBNot" fe [E ee] + _ -> do + let visited' = maybe visited (\k -> S.insert k visited) mkey + cache <- getBNotCache + case (mkey >>= \k -> M.lookup k cache) of + Just r -> deliver pe r + Nothing -> do + P pres res <- + case ew of + IAps f@(ICon _ (ICPrim _ PrimIf)) [_] [c, tb, eb] -> do + P pt tb' <- pushBNot' pos fe visited' tb + P pf eb' <- pushBNot' pos fe visited' eb + -- as in evalStaticOp': improveIf on the BARE branch + -- results, so equal constants collapse, with the + -- branch preds merged under the condition rather than + -- baked into heap cells + (m, _) <- improveIf f itBit1 c tb' eb' + p' <- pIf c pt pf + return (P p' m) + IAps (ICon _ (ICPrim _ PrimArrayDynSelect)) _ _ -> + -- arrays keep the static-op path (the selectable + -- elements need the array machinery); the elements are + -- pushed with the SAME visited set -- re-entering via + -- the evaluator would reset the cycle guard and loop + evalStaticOp ee itBit1 (pushBNot' pos fe visited') + -- undet scrutinees and book-keeping wrappers also take + -- the static-op path (its doUndet and PrimSetSelPosition + -- arms), with pushBNot' as the leaf handler, as the + -- stock evalStaticOp recursion would have handled them + ICon _ (ICUndet {}) -> + evalStaticOp ee itBit1 (pushBNot' pos fe visited') + IAps (ICon _ (ICPrim _ PrimSetSelPosition)) _ _ -> + evalStaticOp ee itBit1 (pushBNot' pos fe visited') + _ -> bnotLeaf ee ew + case res of + -- do NOT heap or cache a residual dyn-select: a heaped + -- select is frozen WHNF, but a select over elements with + -- implicit conditions can only be collapsed by re-entering + -- the evaluator (doDynSel is the one place that strips the + -- elements' preds, carrying them in pSel, and merges + -- all-equal elements) -- so it must stay INLINE, as the + -- stock static-op path returned it, for consumers to + -- re-dispatch + IAps (ICon _ (ICPrim _ PrimArrayDynSelect)) _ _ -> + return (P (pConj pe pres) res) + _ -> + case mkey of + Just k -> do + -- cache the heaped form (the pred goes into the cell, + -- and unheaping recovers it); the result is delivered + -- through the same path as a cache hit + r <- toHeapWHNF "bnot-push" itBit1 (P pres res) Nothing + updBNotCache k r + deliver pe r + Nothing -> return (P (pConj pe pres) res) + where + bnotLeaf ee ew = + case doPrimOp pos PrimBNot [] [ew] of + Just (Right r) -> return (pExpr r) + Just (Left errmsg) -> errG (pos, errmsg) + -- re-enter the evaluator on the HEAPED leaf: the leaf is not + -- dyn, so this lands in the strict-prim catch-all, which + -- applies iTransExpr simplifications (e.g. !(a==b) folding) + -- that downstream static folding depends on + Nothing -> evalAp "Prim PrimBNot" fe [E ee] + -- deliver a heaped result: a constant comes back BARE, with the + -- cell's pred lifted into the P, so that equal constants in + -- sibling branches/elements still fold structurally; anything + -- else keeps the shared ref (pointer equality still folds + -- if-of-same-cell, and the pushed DAG stays a DAG) + deliver p r = do + pe'@(P _ e') <- unheap (P p r) + case e' of + ICon _ _ -> return pe' + _ -> return (P p r) + ----------------------------------------------------------------------------- doIs :: HExpr -> [IType] -> ConTagInfo -> diff --git a/src/comp/IExpandUtils.hs b/src/comp/IExpandUtils.hs index 2319ae8e9..4f16dd2f6 100644 --- a/src/comp/IExpandUtils.hs +++ b/src/comp/IExpandUtils.hs @@ -21,6 +21,7 @@ module IExpandUtils( setBackendSpecific, cacheDef, lookupCExprCache, insertCExprCache, addStateVar, step, updHeap, getHeap, {- filterHeapPtrs, -} getSymTab, getDefEnv, getFlags, getCross, getErrHandle, getModuleName, + getBNotCache, updBNotCache, getTypeNormalizer, getTypeNormalizerC, fullTypeNormalizer, instFunType, getNewRuleSuffix, updNewRuleSuffix, @@ -531,6 +532,10 @@ data GState = GState { -- XXX this could be stored in the heap cells? heapWires :: !(M.Map HeapPointer HWireSet), + -- This is a cache for "pushBNot" (see IExpand), so that pushing a + -- negation through a shared if-DAG is O(cells), not O(paths). + heapBNots :: !(M.Map HeapPointer HExpr), + -- XXX what is the Id? flattened name? vars :: [(Id, HStateVar)], -- instantiated verilog modules portTypeMap :: PortTypeMap, -- map of state var -> port -> type @@ -618,6 +623,7 @@ initGState errh flags symt alldefs defId is_noinlined_func pps = newResetId = initResetId, hp = 0, heapWires = M.empty, + heapBNots = M.empty, vars = [], portTypeMap = M.empty, rules = iREmpty, @@ -2640,6 +2646,18 @@ updWireSetCache p ws = do let cache' = M.insert p ws (heapWires s) put s { heapWires = cache' } +{-# INLINE getBNotCache #-} +getBNotCache :: G (M.Map HeapPointer HExpr) +getBNotCache = do s <- get + return (heapBNots s) + +{-# INLINE updBNotCache #-} +updBNotCache :: HeapPointer -> HExpr -> G () +updBNotCache p e = do + s <- get + let cache' = M.insert p e (heapBNots s) + put s { heapBNots = cache' } + {-# INLINE getModuleName #-} getModuleName :: G String getModuleName = do diff --git a/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp b/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp index 5fcf766eb..46eafcaa4 100644 --- a/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp +++ b/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp @@ -15,10 +15,12 @@ compile_verilog_pass Bug1490MyEnum.bsv {} $rtsflags # ----- -# There has been a regression and this example now exhausts the heap -compile_verilog_fail VsortOriginal.bsv {} $rtsflags -# Confirm that the test failed in the way we expect -find_n_strings [make_bsc_vcomp_output_name VsortOriginal.bsv] "Heap exhausted" 1 +# This example (the original bug 1490 report) used to exhaust the heap: +# the evaluator's push of a negation through conditional structure +# traversed the shared if-DAG once per path (exponential in sort depth). +# The push is now memoized per heap cell (pushBNot in IExpand), so the +# original design compiles within the standard limit. +compile_verilog_pass VsortOriginal.bsv {} $rtsflags compile_verilog_pass VsortWorkaround.bsv {} [rts_flags 275] diff --git a/testsuite/bsc.evaluator/performance/BNotShared.bsv b/testsuite/bsc.evaluator/performance/BNotShared.bsv new file mode 100644 index 000000000..a875d95b1 --- /dev/null +++ b/testsuite/bsc.evaluator/performance/BNotShared.bsv @@ -0,0 +1,58 @@ +package BNotShared; + +// Regression test for exponential PrimBNot-push-through-PrimIf over a +// SHARED conditional DAG in the evaluator (IExpand). +// +// Structure: K stages of odd-even conditional swaps over a +// Vector#(N, Bool) of register values. Every swap condition negates a +// previous-stage element (!v[j-1] && v[j]), and that element is ALSO +// referenced in both branches of the stage's PrimIf muxes, so the +// elaborated value graph is a DAG whose if-depth grows by ~2 per stage +// (depth ~ 2K) while every node is shared. An evaluator that pushes +// PrimBNot through PrimIf once per PATH (evalStaticOp: no memoization, +// plus a fresh evalAp heap application per leaf visit) must walk +// ~2^(2K) branch paths: at K=64 that is ~10^38 operations, i.e. it +// never terminates. The per-heap-cell memoized push is O(N*K) cells +// and compiles in a few seconds. +// +// Deliberately NO pack/unpack (and no (* noinline *)) anywhere in the +// dataflow: the vector stays Vector#(N, Bool) end to end, so even a +// compiler that materializes pack/unpack coercions eagerly (stock +// upstream bsc) preserves the sharing and hits the same blowup. + +import Vector :: *; + +typedef 16 N; // vector width (leaf register cells) +typedef 64 K; // full odd-even steps (if-depth grows ~2 per step) + +// One full odd-even transposition step over plain Bools. +// "less than" for Bools is (!l && r), as in the byte-enable sort. +function Vector#(n, Bool) oestep (Vector#(n, Bool) vx); + Vector#(n, Bool) evn = vx; + for (Integer j = 1; j < valueOf(n); j = j + 2) + if (!vx[j-1] && vx[j]) begin + evn[j-1] = vx[j]; + evn[j] = vx[j-1]; + end + Vector#(n, Bool) odd = evn; + for (Integer j = 2; j < valueOf(n); j = j + 2) + if (!evn[j-1] && evn[j]) begin + odd[j-1] = evn[j]; + odd[j] = evn[j-1]; + end + return odd; +endfunction + +(* synthesize *) +module mkBNotShared (Empty); + Vector#(N, Reg#(Bool)) rs <- replicateM(mkRegU); + + rule step; + Vector#(N, Bool) v = readVReg(rs); + for (Integer s = 0; s < valueOf(K); s = s + 1) + v = oestep(v); + writeVReg(rs, v); + endrule +endmodule + +endpackage diff --git a/testsuite/bsc.evaluator/performance/performance.exp b/testsuite/bsc.evaluator/performance/performance.exp index e3acdf34e..a3cadf096 100644 --- a/testsuite/bsc.evaluator/performance/performance.exp +++ b/testsuite/bsc.evaluator/performance/performance.exp @@ -1,2 +1,9 @@ compile_verilog_pass broken.bsv "" "+RTS -M384M -RTS" compile_verilog_pass TestPIf.bsv "" "+RTS -M265M -RTS" + +# Pushing a negation through a SHARED conditional DAG must be O(cells), +# not O(paths): this design's conditional-swap stages build a DAG with +# ~2^129 then/else paths (16 registers x 64 stages, no pack/unpack +# involved), so a per-path push cannot terminate, while the memoized +# push (pushBNot in IExpand) compiles it in seconds with default limits. +compile_verilog_pass BNotShared.bsv From 08beeb08022d99a089e181023b1f27489c32bf85 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Sun, 5 Jul 2026 14:58:51 -0700 Subject: [PATCH 16/18] testsuite: unify the b1490 heap caps at 288M, above bsc's -H256m hint The GHC 9.12.2 and 9.14.1 CI jobs fail VsortOriginal at the 256M cap ("Heap exhausted") while GHC 9.6.7 passes. The live set is ~20 MB; what the cap was actually measuring is bsc's baked-in allocation-area hint (-with-rtsopts=-H256m, src/comp/Makefile), which sizes the RTS heap toward 256M regardless of need, with a steady state a few MB above it (262-267 MiB observed on GHC 9.6.7 and 9.12.4). Caps at or just above the hint ride the RTS's boundary accounting, which shifts with GHC version and OS -- the same edge that has needed repeated per-test nudges (272, then 275 in 1eba70540aad). Set one uniform 288M cap -- the hint plus real margin -- and drop the per-test overrides. This still proves what the directory cares about: bug 1490 made these compiles exhaust memory exponentially in the sort depth, so any fixed few-hundred-MB cap separates fixed from broken by orders of magnitude. All six tests pass under a GHC 9.12.4 build at 288M. Co-Authored-By: Claude Fable 5 --- .../bsc.bugs/bluespec_inc/b1490/b1490.exp | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp b/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp index 46eafcaa4..d5dccc7a4 100644 --- a/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp +++ b/testsuite/bsc.bugs/bluespec_inc/b1490/b1490.exp @@ -1,16 +1,21 @@ -set rtsflags {+RTS -M256M -Sstderr -RTS} - -# For tests that need more than the default -proc rts_flags { heapsize } { - return "+RTS -M${heapsize}M -Sstderr -RTS" -} +# The heap cap must comfortably clear bsc's baked-in allocation-area hint +# (-with-rtsopts=-H256m, src/comp/Makefile): the RTS sizes its heap toward +# the hint no matter how small the live set is, with a steady state a few +# MB above it. Caps at or just above 256M measure the RTS's boundary +# accounting -- which varies by GHC version and OS -- rather than the +# compile, and have needed repeated per-test nudges (272, 275) as CI +# configurations shifted. One uniform cap with real margin over the hint +# still proves what this directory cares about: bug 1490 made these +# compiles exhaust memory EXPONENTIALLY in the sort depth, so any fixed +# few-hundred-MB cap separates fixed from broken by orders of magnitude. +set rtsflags {+RTS -M288M -Sstderr -RTS} # ----- compile_verilog_pass Bug1490Bool.bsv {} $rtsflags compile_verilog_pass Bug1490MyBool.bsv {} $rtsflags -compile_verilog_pass Bug1490MyUnion.bsv {} [rts_flags 272] +compile_verilog_pass Bug1490MyUnion.bsv {} $rtsflags compile_verilog_pass Bug1490MyEnum.bsv {} $rtsflags # ----- @@ -22,6 +27,6 @@ compile_verilog_pass Bug1490MyEnum.bsv {} $rtsflags # original design compiles within the standard limit. compile_verilog_pass VsortOriginal.bsv {} $rtsflags -compile_verilog_pass VsortWorkaround.bsv {} [rts_flags 275] +compile_verilog_pass VsortWorkaround.bsv {} $rtsflags # ----- From 71226f07d9b9d6cc39f43ba233efa481d5fc53e4 Mon Sep 17 00:00:00 2001 From: Ravi Nanavati Date: Fri, 10 Jul 2026 21:22:49 -0700 Subject: [PATCH 17/18] Corner-case fixes to instance trie lookup GitHub PR 1032. * Fix instance-trie ordering and probing holes in coherence detection Three defects let the PredTrie-based instance index (05865c6f) select or admit instances that the legacy all-pairs index would not, each undermining the coherence certificate that instance resolution and the planned coherent-dictionary work depend on: 1. Leaf ordering. cmpQInsts yields only a partial order (non- overlapping instances are incomparable), and sortBy with the EQ-collapsed comparator is not a sound way to linearize a partial order: an incomparable instance between two comparable ones can keep the sort from ever comparing them. A leaf then keeps a catch-all ahead of a strictly-more-specific instance, and a fully concrete pred selects the catch-all with no incoherence flagged (and no T0128, since the pair is orderable). Order each leaf with a topological sort of the strict specificity edges instead, as getQInstsLegacy does for the whole list. To keep this from adding pairwise comparisons, the overlap check and the leaf sort now share a lazily memoized cmpQInsts table keyed on the canonical index pair; same-leaf pairs were already being compared by the overlap probes, so the sort costs no additional cmpQInsts calls (library build time is unchanged). 2. Primitive type functions in instance heads. An instance head like NP2 (TAdd a b) was keyed under Con TAdd, where probes for the numeric-literal instances it can evaluate to never look, so the overlap check silently admitted pairs the legacy index rejects with T0128. Key unstable heads as Nothing (catch-all branch) so such instances are visible to every query and every overlap probe. 3. Stuck associated type functions in queries. normT leaves a fully applied ATF in place when its class predicate is not yet satisfiable, and mkQueryElem keyed such a pred argument as Con (ATF), probing only the ATF's own (empty) branch plus the catch-all branch. Concrete instances the pred could match after the ATF resolves were neither tried nor visible to the incoherence check, so a catch-all match was committed as if coherent. Treat ATF heads as Free (probe all branches), like prim type functions. Also treat prim-type-function heads as inconclusive in the legacy index's canMatch pre-filter (TAdd a b vs TyNum heads are unifiable, not a constructor clash). New tests in bsc.typechecker/instances/order --- src/comp/MakeSymTab.hs | 79 +++++++++++++---- src/comp/PredTrie.hs | 84 ++++++++++++------- src/comp/TCMisc.hs | 10 ++- src/comp/Util.hs | 5 ++ .../instances/order/FdStability.bs | 62 ++++++++++++++ .../instances/order/LeafOrder.bs | 39 +++++++++ .../instances/order/LeafOrderChain.bs | 42 ++++++++++ .../bsc.typechecker/instances/order/Makefile | 5 ++ .../instances/order/StuckATF.bs | 30 +++++++ .../order/StuckATF.bs.bsc-out.expected | 15 ++++ .../instances/order/TFunHead.bs | 24 ++++++ .../bsc.typechecker/instances/order/order.exp | 70 ++++++++++++++++ .../order/sysFdStability.out.expected | 2 + .../instances/order/sysLeafOrder.out.expected | 1 + .../order/sysLeafOrderChain.out.expected | 4 + 15 files changed, 422 insertions(+), 50 deletions(-) create mode 100644 testsuite/bsc.typechecker/instances/order/FdStability.bs create mode 100644 testsuite/bsc.typechecker/instances/order/LeafOrder.bs create mode 100644 testsuite/bsc.typechecker/instances/order/LeafOrderChain.bs create mode 100644 testsuite/bsc.typechecker/instances/order/Makefile create mode 100644 testsuite/bsc.typechecker/instances/order/StuckATF.bs create mode 100644 testsuite/bsc.typechecker/instances/order/StuckATF.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/instances/order/TFunHead.bs create mode 100644 testsuite/bsc.typechecker/instances/order/order.exp create mode 100644 testsuite/bsc.typechecker/instances/order/sysFdStability.out.expected create mode 100644 testsuite/bsc.typechecker/instances/order/sysLeafOrder.out.expected create mode 100644 testsuite/bsc.typechecker/instances/order/sysLeafOrderChain.out.expected diff --git a/src/comp/MakeSymTab.hs b/src/comp/MakeSymTab.hs index 4739d27be..d792cae01 100644 --- a/src/comp/MakeSymTab.hs +++ b/src/comp/MakeSymTab.hs @@ -916,15 +916,18 @@ genBss vs fds = [ map (`elem` rs) vs | (_, rs) <- fds ] -- Check for overlap errors using the shared instance trie. -- Variable positions in the instance key become Free in the probe query --- so cross-branch overlaps are correctly found. j /= i avoids self-comparison. -overlapErrors :: [[Bool]] -> [(Int, QInst, Inst)] -> PredTrie (Int, QInst, Inst) -> [EMsg] -overlapErrors bss tagged trie = nub errs +-- so cross-branch overlaps are correctly found. j > i avoids self-comparison +-- and processes each unordered pair only once, in the canonical (low, high) +-- direction that the memo table (see getCls) stores. +overlapErrors :: (Int -> Int -> Either EMsg (Maybe Ordering)) -> + [(Int, QInst, Inst)] -> PredTrie (Int, QInst, Inst) -> [EMsg] +overlapErrors pairCmp tagged trie = nub errs where probeQuery (_, _, Inst _ _ (_ :=> p) _) = overlapProbeQuery p - errs = [ e | item@(i, qi, _) <- tagged - , (j, qj, _) <- lookupPredTrie (probeQuery item) trie - , j > i -- process each unordered pair only once - , Left e <- [cmpQInsts bss qi qj] ] + errs = [ e | item@(i, _, _) <- tagged + , (j, _, _) <- lookupPredTrie (probeQuery item) trie + , j > i + , Left e <- [pairCmp i j] ] -- --------------- @@ -980,17 +983,59 @@ getCls errh mi src_pkg iks r incoh ps ik vs fds ifs qts = -- identity for the overlap self-check; QInst is needed by -- cmpQInsts; Inst is what genInsts returns. tagged = zip3 [0 :: Int ..] qinsts all_insts - -- cmpQInsts freshens type variables before comparing, so - -- specificity is correctly detected even when instances share - -- variable names (e.g. both use 'a' and 'b'). - cmpForSort (_, qi1, _) (_, qi2, _) = - case cmpQInsts bss qi1 qi2 of - Right (Just LT) -> LT -- qi1 more specific, try first - Right (Just GT) -> GT -- qi1 less specific, try last - _ -> EQ - trie = buildPredTrie cmpForSort + -- Pairwise instance comparisons, memoized in a lazy Map + -- keyed on the canonical (low, high) index pair, so that + -- the overlap check and the leaf sort below each force a + -- given pair's cmpQInsts at most once between them. + -- (cmpQInsts freshens type variables before comparing, so + -- specificity is correctly detected even when instances + -- share variable names.) + cmpMemo = M.fromList + [ ((i, j), cmpQInsts bss qi qj) + | ((i, qi, _) : rest) <- tails tagged + , (j, qj, _) <- rest ] + pairCmp i j + | i == j = internalError "MakeSymTab.getCls: pairCmp i i" + | i < j = find_cmp (i, j) + | otherwise = fmap (fmap flipOrd) (find_cmp (j, i)) + where find_cmp k = fromJustOrErr "MakeSymTab.getCls: pairCmp" + (M.lookup k cmpMemo) + flipOrd LT = GT + flipOrd GT = LT + flipOrd EQ = EQ + -- Order each trie leaf most-specific-first. cmpQInsts + -- yields only a partial order: non-overlapping instances + -- are incomparable. A comparison sort is not sound for a + -- partial order — an incomparable instance between two + -- comparable ones can keep the sort from ever comparing + -- them, leaving a less-specific instance ahead of a + -- strictly-more-specific one (which byInst would then + -- select, with no incoherence flagged). So topologically + -- sort the strict specificity edges, as getQInstsLegacy + -- does for the whole instance list. Instances share a + -- leaf only when they agree on the head constructor at + -- every pure-input position, and the leaf's pairs have + -- already been compared by the overlap check, so this + -- costs no additional cmpQInsts calls. + sortLeaf items@(_:_:_) = + let g = [ (i, [ j | (j, _, _) <- items, i /= j, + pairCmp j i == Right (Just LT) ]) + | (i, _, _) <- items ] + im = M.fromList [ (idx, item) | item@(idx, _, _) <- items ] + in case tsort g of + Right is -> + [ map_lookupOrErr + ("MakeSymTab.sortLeaf: tsort returned " ++ + "an index not in the leaf: " ++ show i) + i im + | i <- is ] + Left cycles -> + internalError ("MakeSymTab.sortLeaf cycles? " ++ + ppReadable cycles) + sortLeaf items = items + trie = buildPredTrie sortLeaf (\(_, _, Inst _ _ (_ :=> p) _) -> p) tagged - errs = overlapErrors bss tagged trie + errs = overlapErrors pairCmp tagged trie -- S.empty suppresses Bound: for overlapping classes like -- AppendTuple''/Has_tpl_n, a non-matching concrete instance -- must be visible to trigger the incoherent path in diff --git a/src/comp/PredTrie.hs b/src/comp/PredTrie.hs index 8bcee73de..9b4cee54b 100644 --- a/src/comp/PredTrie.hs +++ b/src/comp/PredTrie.hs @@ -13,13 +13,11 @@ module PredTrie( import Prelude hiding ((<>)) #endif -import Data.List(sortBy) - import qualified Data.Map.Strict as M import qualified Data.Set as S import Error(internalError) -import CType(Type(..), TyCon(..), TyVar, leftTyCon) +import CType(Type(..), TyCon(..), TISort(..), TyVar, leftTyCon) import TypeOps(isPrimTFunName) import Pred(Pred(..), Class(inputPositions), expandSyn) @@ -43,19 +41,22 @@ data PredTrie a = Leaf [a] -- | Build a sorted trie from items that contain predicates. The class (and -- hence its functional dependencies) is taken from the first item's predicate, -- so the caller need not pass the fundep matrix separately. --- The comparator is applied at construction time so that lookupPredTrie --- returns items in the caller's preferred order. The comparator should place --- more-specific items before less-specific ones: lookupPredTrie already +-- The leaf-sorting function is applied at construction time so that +-- lookupPredTrie returns items in the caller's preferred order. It should +-- place more-specific items before less-specific ones: lookupPredTrie already -- returns items from more-specific branches (concrete constructor) before -- less-specific branches (type variable), so the leaf ordering should be --- consistent with that — more-specific items first. +-- consistent with that — more-specific items first. It is a whole-list +-- function, not a comparator, because specificity is only a partial order +-- and a comparison sort of a partial order is not sound (see the caller in +-- MakeSymTab). -- The item type 'a' is unrestricted, so this works for Inst, EPred, VPred, -- or any wrapper. -buildPredTrie :: (a -> a -> Ordering) -> (a -> Pred) -> [a] -> PredTrie a -buildPredTrie _ _ [] = Leaf [] -buildPredTrie cmp toPred items@(x:_) = +buildPredTrie :: ([a] -> [a]) -> (a -> Pred) -> [a] -> PredTrie a +buildPredTrie _ _ [] = Leaf [] +buildPredTrie sortLeaf toPred items@(x:_) = let IsIn c _ = toPred x - in sortTrieLeaves cmp $ buildRaw (\y -> predTrieKey (inputPositions c) (toPred y)) items + in sortTrieLeaves sortLeaf $ buildRaw (\y -> predTrieKey (inputPositions c) (toPred y)) items buildRaw :: (a -> [Maybe TyCon]) -> [a] -> PredTrie a buildRaw keyOf items@(x:_) = @@ -84,11 +85,11 @@ trieShape :: PredTrie a -> String trieShape (Leaf xs) = "Leaf[" ++ show (length xs) ++ "]" trieShape (Node _) = "Node" --- | Sort the items in each leaf using a comparison function. +-- | Sort the items in each leaf using a whole-list sorting function. -- Use this once at build time so that lookupPredTrie returns items in order. -sortTrieLeaves :: (a -> a -> Ordering) -> PredTrie a -> PredTrie a -sortTrieLeaves cmp (Leaf xs) = Leaf (sortBy cmp xs) -sortTrieLeaves cmp (Node m) = Node (M.map (sortTrieLeaves cmp) m) +sortTrieLeaves :: ([a] -> [a]) -> PredTrie a -> PredTrie a +sortTrieLeaves f (Leaf xs) = Leaf (f xs) +sortTrieLeaves f (Node m) = Node (M.map (sortTrieLeaves f) m) -- --------------------------------------------------------------------------- -- Querying the trie @@ -158,16 +159,26 @@ allItems (Node m) = concatMap allItems (M.elems m) -- Trie key for a predicate at the given pre-computed positions. -- Type synonyms are expanded so that keys are in normal form, matching the -- post-normT predicate types used at query time. +-- Only substitution-stable head constructors (see stableHeadTyCon) are used +-- as keys. A type-function head (e.g. TAdd) is keyed Nothing so the +-- instance lands in the catch-all branch: it can evaluate to any head as +-- types refine, so it must be visible to every query and to every overlap +-- probe (keying it under its own constructor would hide it from probes for +-- the heads it can evaluate to, silently skipping the overlap check and +-- the incoherence detection against such instances). predTrieKey :: [Int] -> Pred -> [Maybe TyCon] predTrieKey positions (IsIn _ ts) = - [ leftTyCon (expandSyn (ts !! i)) | i <- positions ] + [ case leftTyCon (expandSyn (ts !! i)) of + Just tc | stableHeadTyCon tc -> Just tc + _ -> Nothing + | i <- positions ] -- | Probe query for overlap checking: given an instance's predicate, build a -- query that finds all instances that might overlap with it. Variable positions -- in the instance key (Nothing) become Free so that cross-branch overlaps are --- found; concrete positions (Just tc) become Con tc. --- Unlike predQuery this does not apply isPrimTFunTyCon: for overlap detection we --- want to find all candidates including those with numeric-literal heads. +-- found; concrete positions (Just tc) become Con tc. Type-function heads are +-- keyed Nothing by predTrieKey and therefore probe Free here, so instances +-- they might overlap with are always found. overlapProbeQuery :: Pred -> [QueryElem] overlapProbeQuery p@(IsIn c _) = [ case k of { Just tc -> Con tc; Nothing -> Free } @@ -188,24 +199,37 @@ predQuery btvs (IsIn c ts) = -- Building queries from predicates -- --------------------------------------------------------------------------- --- | True when a TyCon is an unevaluated numeric or string type function --- (TAdd, TMul, TLog, etc.). Type-function heads cannot be resolved to a --- concrete constructor at query time, so queries at those positions must --- probe ALL trie branches (Free) to avoid missing instances that have a --- concrete-number head (e.g. VectorTreeReduce 1, VectorTreeReduce 2). -isPrimTFunTyCon :: TyCon -> Bool -isPrimTFunTyCon (TyCon { tcon_name = i }) = isPrimTFunName i -isPrimTFunTyCon _ = False +-- | True when a TyCon head is stable under substitution and normalization: +-- ordinary type constructors and numeric/string literals. False for heads +-- that can still evaluate or expand to a different head as types refine: +-- - primitive numeric/string type functions (TAdd, TMul, TLog, etc.); +-- - associated type functions (TIatf), which normT can leave in place +-- when their class predicate is not yet satisfiable ("stuck" ATFs); +-- - type synonyms (TItype), defensively — they are normally expanded +-- before keys and queries are built. +-- Unstable heads must be keyed Nothing on the instance side and must probe +-- ALL trie branches (Free) on the query side; otherwise a query for a +-- pred whose head later evaluates to a concrete constructor would never +-- see the instances under that constructor (e.g. VectorTreeReduce 1, +-- VectorTreeReduce 2), missing both matches and the non-matching-but- +-- unifiable instances that incoherence detection depends on. +stableHeadTyCon :: TyCon -> Bool +stableHeadTyCon (TyCon { tcon_name = i, tcon_sort = s }) = + case s of + TItype {} -> False + TIatf {} -> False + _ -> not (isPrimTFunName i) +stableHeadTyCon _ = True -- TyNum, TyStr -- | Classify one type argument of the predicate being resolved. --- A type-function head (TAdd, TLog, etc.) is treated as Free so that +-- An unstable head (type function, stuck ATF) is treated as Free so that -- all candidate instances are returned for unification-based filtering. -- Pass 'S.empty' for btvs to suppress Bound (never emit Bound in queries). mkQueryElem :: S.Set TyVar -> Type -> QueryElem mkQueryElem btvs t = case leftTyCon t of - Just tc | not (isPrimTFunTyCon tc) -> Con tc - Just _ -> Free -- unevaluated type function + Just tc | stableHeadTyCon tc -> Con tc + Just _ -> Free -- unevaluated type function Nothing -> case headVar t of Just tv | tv `S.member` btvs -> Bound _ -> Free diff --git a/src/comp/TCMisc.hs b/src/comp/TCMisc.hs index 9ddf11f23..fe6e97c5d 100644 --- a/src/comp/TCMisc.hs +++ b/src/comp/TCMisc.hs @@ -29,6 +29,7 @@ import Id import Error(internalError, EMsg, ErrMsg(..)) import Flags(Flags, useProvisoSAT) import Type +import TypeOps(isPrimTFunName) import Subst import Assump import Scheme @@ -588,13 +589,16 @@ reducePred eps dvs (VPred w pp@(PredWithPositions pr@(IsIn c ts) pos)) = do (Just pc, Just ic) -> pc == ic _ -> True | (False, pt, it) <- zip3 bs pred_ts inst_ts ] - -- Extract head TyCon Id only if it's not a type synonym or ATF - -- (those could expand to match anything) + -- Extract head TyCon Id only if it's not a type synonym, ATF, + -- or primitive type function (those could expand/evaluate to + -- match anything, so a head mismatch is not a clash) leftNonSynTyCon t = case leftTyCon t of Just (TyCon _ _ (TItype {})) -> Nothing -- synonym Just (TyCon _ _ (TIatf {})) -> Nothing -- ATF - Just (TyCon i _ _) -> Just i + Just (TyCon i _ _) + | isPrimTFunName i -> Nothing -- TAdd etc. + | otherwise -> Just i _ -> Nothing f :: Bool -> [Inst] -> TI (Maybe ([VPred], SolvedBind, Subst, Maybe Pred, Maybe Id)) diff --git a/src/comp/Util.hs b/src/comp/Util.hs index 1007455d0..681ed705d 100644 --- a/src/comp/Util.hs +++ b/src/comp/Util.hs @@ -485,6 +485,11 @@ isRight _ = False -- ===== -- Data.Map utilities +-- like M.!, but reports lookup failure via internalError +-- (in the style of headOrErr) +map_lookupOrErr :: (Ord k) => String -> k -> M.Map k a -> a +map_lookupOrErr err k m = M.findWithDefault (internalError err) k m + map_insertMany :: (Ord k) => [(k,a)] -> M.Map k a -> M.Map k a map_insertMany kas m = foldr (uncurry M.insert) m kas diff --git a/testsuite/bsc.typechecker/instances/order/FdStability.bs b/testsuite/bsc.typechecker/instances/order/FdStability.bs new file mode 100644 index 000000000..832d28cfc --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/FdStability.bs @@ -0,0 +1,62 @@ +package FdStability where + +-- Pin the resolution behavior that makes fundep improvements from a +-- matched instance unsafe to commit before the instance's context is +-- discharged. +-- +-- TC (Maybe t) m first matches the specific instance, whose fundep +-- output would improve m to 5 -- but its (TD t) context cannot be +-- discharged while t is unresolved, so the attempt is abandoned and +-- the improvement is NOT committed. The sibling pred TC2 Bool m then +-- commits m := 6, and on retry the specific TC instance no longer +-- matches (5 ~ 6 fails) and no longer unifies, so the catch-all is +-- selected coherently. A direct call at Maybe Bool, where (TD Bool) +-- is available, selects the specific instance instead. +-- +-- Any future scheme that commits a coherent match (or its fundep +-- substitution) before its context is discharged must still defer +-- here -- the catch-all instance unifies with the pred at match time, +-- so the improvement m := 5 is not final -- or it would reject this +-- program. Expected output: 1 (direct, specific) then 2 (through +-- foo, catch-all). + +class TC x n | x -> n where + tcVal :: x -> Bit n + tcTag :: x -> Bit 8 + +instance (TD a) => TC (Maybe a) 5 where + tcVal _ = 0 + tcTag _ = 1 + +instance TC x 6 where + tcVal _ = 0 + tcTag _ = 2 + +class TD a where + tdVal :: a -> Bool + +instance TD Bool where + tdVal x = x + +class TC2 x n | x -> n where + tc2Val :: x -> Bit n + +instance TC2 Bool 6 where + tc2Val _ = 0 + +-- forces the two fundep outputs to be the same variable +h :: Bit n -> Bit n -> Bool +h _ _ = True + +foo :: Maybe t -> Bool -> Bit 8 +foo x b = if h (tcVal x) (tc2Val b) then tcTag x else 0 + +{-# verilog sysFdStability #-} +sysFdStability :: Module Empty +sysFdStability = module + rules + "test": when True ==> + action + $display "%0d" (tcTag (Just True)) -- direct: specific -> 1 + $display "%0d" (foo (Just True) False) -- via foo: catch-all -> 2 + $finish 0 diff --git a/testsuite/bsc.typechecker/instances/order/LeafOrder.bs b/testsuite/bsc.typechecker/instances/order/LeafOrder.bs new file mode 100644 index 000000000..47cc0217a --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/LeafOrder.bs @@ -0,0 +1,39 @@ +package LeafOrder where + +-- Test that instances sharing one instance-trie leaf are walked +-- most-specific-first. +-- +-- All three instances below have the same head constructor (Maybe) at both +-- class parameter positions, so they land in the same PredTrie leaf. The +-- leaf must be ordered by specificity, but specificity is only a partial +-- order: the middle instance overlaps neither of the others (the first +-- instance's repeated type variable cannot unify with two different +-- element types), so a comparison sort sees EQ against both neighbors and +-- may never compare the first and last instances at all, leaving the +-- catch-all ahead of the strictly-more-specific instance in declaration +-- order. A correct topological ordering puts the specific instance first. +-- +-- The instances are deliberately declared least-specific-first with the +-- non-comparable instance in between; a fully concrete call must select +-- the most specific instance (3), not the catch-all (1). + +class TC a b where + tcName :: a -> b -> Bit 8 + +instance TC (Maybe a) (Maybe a) where + tcName _ _ = 1 + +instance TC (Maybe Bool) (Maybe (Bit 8)) where + tcName _ _ = 2 + +instance TC (Maybe Bool) (Maybe Bool) where + tcName _ _ = 3 + +{-# verilog sysLeafOrder #-} +sysLeafOrder :: Module Empty +sysLeafOrder = module + rules + "test": when True ==> + action + $display "%0d" (tcName (Just True) (Just False)) + $finish 0 diff --git a/testsuite/bsc.typechecker/instances/order/LeafOrderChain.bs b/testsuite/bsc.typechecker/instances/order/LeafOrderChain.bs new file mode 100644 index 000000000..dcb805eba --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/LeafOrderChain.bs @@ -0,0 +1,42 @@ +package LeafOrderChain where + +-- A deeper exercise of trie-leaf ordering: four instances in one leaf +-- (all Maybe/Maybe at the input positions) forming a specificity chain +-- A < B < C with an incomparable instance X (X < C only): +-- +-- C = TC3 (Maybe a) (Maybe b) -- fully general +-- B = TC3 (Maybe a) (Maybe a) -- non-linear, B < C +-- X = TC3 (Maybe Bool) (Maybe (Bit 8)) -- X < C; unrelated to A, B +-- A = TC3 (Maybe Bool) (Maybe Bool) -- A < B < C +-- +-- Declared in the adversarial order [C, B, X, A]: a comparison sort of +-- the collapsed partial order leaves both C ahead of X and B ahead of +-- A, so concrete calls would select C (4) instead of X (2) and B (3) +-- instead of A (1). A topological ordering must answer 1, 3, 2, 4. + +class TC3 a b where + tag3 :: a -> b -> Bit 8 + +instance TC3 (Maybe a) (Maybe b) where + tag3 _ _ = 4 + +instance TC3 (Maybe a) (Maybe a) where + tag3 _ _ = 3 + +instance TC3 (Maybe Bool) (Maybe (Bit 8)) where + tag3 _ _ = 2 + +instance TC3 (Maybe Bool) (Maybe Bool) where + tag3 _ _ = 1 + +{-# verilog sysLeafOrderChain #-} +sysLeafOrderChain :: Module Empty +sysLeafOrderChain = module + rules + "test": when True ==> + action + $display "%0d" (tag3 (Just True) (Just False)) -- A + $display "%0d" (tag3 (Just (0 :: Bit 8)) (Just (1 :: Bit 8))) -- B + $display "%0d" (tag3 (Just True) (Just (1 :: Bit 8))) -- X + $display "%0d" (tag3 (Just (0 :: Bit 8)) (Just True)) -- C + $finish 0 diff --git a/testsuite/bsc.typechecker/instances/order/Makefile b/testsuite/bsc.typechecker/instances/order/Makefile new file mode 100644 index 000000000..607fb8db7 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/Makefile @@ -0,0 +1,5 @@ +# for "make clean" to work everywhere + +CONFDIR = $(realpath ../../..) + +include $(CONFDIR)/clean.mk diff --git a/testsuite/bsc.typechecker/instances/order/StuckATF.bs b/testsuite/bsc.typechecker/instances/order/StuckATF.bs new file mode 100644 index 000000000..01237c80a --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/StuckATF.bs @@ -0,0 +1,30 @@ +package StuckATF where + +-- Pin the treatment of a pred over a stuck associated type function: +-- NPick at type SizeOf a, with a rigid and no (Bits a n) given. The +-- ATF cannot expand, and the instance-trie probe must see ALL NPick +-- instances: NPick 1 is unifiable with the pred, so the catch-all +-- match is incoherent and must be deferred and reported (this file's +-- expected output pins NPick among the needed contexts), never +-- silently committed as coherent. +-- +-- Note this pins an invariant rather than a reachable bug: signature +-- conversion expands the ATF into a (Bits a n) context and a fresh +-- variable, so the pred reaches the instance probe as NPick n, not +-- NPick (SizeOf a) -- as do all other current surface inlets +-- (annotations, data fields, instance heads, synonyms). The pin +-- guards the probe for any internal path that skips an expansion +-- gate, where a Con-keyed ATF probe would hide NPick 1 and certify +-- the catch-all as coherent. + +class NPick n where + npick :: Bit n -> Bit 8 + +instance NPick 1 where + npick _ = 1 + +instance NPick n where + npick _ = 2 + +noBits :: a -> Bit 8 +noBits _ = npick (0 :: Bit (SizeOf a)) diff --git a/testsuite/bsc.typechecker/instances/order/StuckATF.bs.bsc-out.expected b/testsuite/bsc.typechecker/instances/order/StuckATF.bs.bsc-out.expected new file mode 100644 index 000000000..d08ea0ff1 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/StuckATF.bs.bsc-out.expected @@ -0,0 +1,15 @@ +checking package dependencies +compiling StuckATF.bs +Error: "StuckATF.bs", line 29, column 0: (T0030) + The contexts for this expression are too general. + Given type: + a -> Prelude.Bit 8 + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "StuckATF.bs", line 30, column 28 + StuckATF.NPick a__ + Introduced at the following locations: + "StuckATF.bs", line 30, column 11 + The type variables are from the following positions: + "a__" at "StuckATF.bs", line 30, column 28 diff --git a/testsuite/bsc.typechecker/instances/order/TFunHead.bs b/testsuite/bsc.typechecker/instances/order/TFunHead.bs new file mode 100644 index 000000000..9f5e1435e --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/TFunHead.bs @@ -0,0 +1,24 @@ +package TFunHead where + +-- Test that an instance whose head contains a primitive numeric type +-- function (TAdd) participates in overlap checking. +-- +-- TAdd a b unifies with the literal 5 (numeric unification defers an +-- equality), so these two instances overlap without being orderable and +-- must be rejected (T0128). In the instance trie, a TAdd-headed instance +-- must not be keyed under the TAdd constructor: probes for the +-- literal-headed instance would then never see it and the overlapping +-- pair would be silently admitted. +-- +-- The class carries a fundep so that a and b are determined and the +-- instances are otherwise legal; the overlap of the first parameter is +-- the only error here. + +class NP2 n a b | n -> a b where + np2 :: Bit n -> (Bit a, Bit b) + +instance NP2 (TAdd a b) a b where + np2 _ = (0, 0) + +instance NP2 5 2 3 where + np2 _ = (1, 1) diff --git a/testsuite/bsc.typechecker/instances/order/order.exp b/testsuite/bsc.typechecker/instances/order/order.exp new file mode 100644 index 000000000..d802258d3 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/order.exp @@ -0,0 +1,70 @@ +# Tests for the order in which class instances are tried during +# context reduction (most-specific-first), in corners where the +# instance trie's ordering or probing could disagree with the +# legacy all-pairs index. +# +# The trie and legacy variants must recompile from source (not reuse a +# .bo produced by the other variant, which would bake in that variant's +# instance choice), so the .bo is erased between variants. + +# Three instances share one trie leaf; the middle one overlaps neither +# of the others, so specificity is only a partial order on the leaf. +# A fully concrete call must select the most specific instance (3), +# not the declaration-first catch-all (1). Before the per-leaf +# topological sort, the trie leaf kept declaration order here (the +# comparison sort never compares the first and last instances) and the +# catch-all was selected; the legacy index has always ordered this +# correctly, so only the default variant exposed the bug. +test_c_veri LeafOrder sysLeafOrder.out.expected +erase LeafOrder.bo +# Legacy instance index must produce identical output. +test_c_veri_bs_modules_options LeafOrder {} {-legacy-inst-index} sysLeafOrder.out.expected + +# A deeper leaf: four instances forming a specificity chain A < B < C +# plus an instance X incomparable to A and B, declared adversarially. +# Each of the four calls must select the most specific matching +# instance (1, 3, 2, 4); a comparison sort of the collapsed partial +# order answers 3 for the first call. +test_c_veri LeafOrderChain sysLeafOrderChain.out.expected +erase LeafOrderChain.bo +test_c_veri_bs_modules_options LeafOrderChain {} {-legacy-inst-index} sysLeafOrderChain.out.expected + +# Fundep improvements from a matched-but-undischarged instance must not +# be committed: the specific TC instance matches first and would improve +# the output position to 5, but its context is not yet satisfiable and a +# sibling pred then fixes the output to 6, after which only the +# catch-all matches (coherently). Pins the acceptance and instance +# choice (1 direct, 2 through the helper) that any future +# commit-coherent-matches scheme must preserve by deferring improving +# matches whose walk suffix still contains a unifiable instance. +test_c_veri FdStability sysFdStability.out.expected +erase FdStability.bo +test_c_veri_bs_modules_options FdStability {} {-legacy-inst-index} sysFdStability.out.expected + +# An instance head containing a primitive numeric type function (TAdd) +# unifies with a numeric-literal head, so the pair overlaps without being +# orderable and must be rejected, under both index implementations. +# Before TAdd-headed instances were keyed into the catch-all branch, the +# trie's overlap probes missed the pair and the default variant compiled +# silently; the legacy all-pairs check has always rejected it. +compile_fail_error TFunHead.bs T0128 +erase TFunHead.bo +compile_fail_error TFunHead.bs T0128 1 {-legacy-inst-index} + +# A pred with a stuck associated-type-function head must probe every +# trie branch, so that unifiable instances (NPick 1 vs NPick (SizeOf a)) +# remain visible to incoherence detection. This pins the invariant +# rather than exposing a live bug: every current surface-syntax inlet +# (signatures, annotations, data fields, instance heads, synonyms) +# expands ATF applications into class contexts at conversion, so the +# pred reaches the probe as NPick a__ with a fresh variable. The pin +# guards the probe behavior for any future path that skips one of +# those expansion gates (as mkVPredFromPred already does). +compile_fail StuckATF.bs +compare_file StuckATF.bs.bsc-out +erase StuckATF.bo +# The legacy index's canMatch pre-filter treats ATF heads as +# inconclusive, so the same instances stay visible and the report is +# identical. +compile_fail StuckATF.bs {-legacy-inst-index} +compare_file StuckATF.bs.bsc-out diff --git a/testsuite/bsc.typechecker/instances/order/sysFdStability.out.expected b/testsuite/bsc.typechecker/instances/order/sysFdStability.out.expected new file mode 100644 index 000000000..1191247b6 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/sysFdStability.out.expected @@ -0,0 +1,2 @@ +1 +2 diff --git a/testsuite/bsc.typechecker/instances/order/sysLeafOrder.out.expected b/testsuite/bsc.typechecker/instances/order/sysLeafOrder.out.expected new file mode 100644 index 000000000..00750edc0 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/sysLeafOrder.out.expected @@ -0,0 +1 @@ +3 diff --git a/testsuite/bsc.typechecker/instances/order/sysLeafOrderChain.out.expected b/testsuite/bsc.typechecker/instances/order/sysLeafOrderChain.out.expected new file mode 100644 index 000000000..6a1a6aa15 --- /dev/null +++ b/testsuite/bsc.typechecker/instances/order/sysLeafOrderChain.out.expected @@ -0,0 +1,4 @@ +1 +3 +2 +4 From 6be62d6306049a4d0889e60e5fac81804872f26f Mon Sep 17 00:00:00 2001 From: Lucas Kramer Date: Fri, 10 Jul 2026 21:33:51 -0700 Subject: [PATCH 18/18] Fix Issue 890 by expanding type functions in tiExpl GitHub PR 916. Type expansion is only used if an ATF is uncovered, otherwise the original type is used, to preserve behavior (structurally matching type synonyms?) that existing code may be relying on. Includes tests from PR 909, which was an earlier attempt that is replaced by this change. --- src/comp/CtxRed.hs | 14 +-- src/comp/TCheck.hs | 9 +- .../bsc.typechecker/primtcons/CExtendATF.bsv | 64 ++++++++++++++ .../primtcons/CExtendATFExplicit.bsv | 55 ++++++++++++ .../primtcons/CExtendSynonym.bsv | 55 ++++++++++++ .../primtcons/ExpSizeOf_FieldSyn_BS.bs | 20 +++++ .../primtcons/ExpSizeOf_FieldSyn_Minimal.bs | 12 +++ .../ExpSizeOf_FieldSyn_Unbound_NoCtx.bs | 25 ++++++ ...FieldSyn_Unbound_NoCtx.bs.bsc-out.expected | 23 +++++ .../ExpSizeOf_FieldSyn_Unbound_WithCtx.bs | 11 +++ .../primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs | 19 ++++ ...eOf_FieldSyn_Use_NoCtx.bs.bsc-out.expected | 12 +++ .../ExpSizeOf_FieldSyn_Use_WithCtx.bs | 15 ++++ .../primtcons/ExpSizeOf_Let_NoCtx.bs | 12 +++ .../ExpSizeOf_Let_NoCtx.bs.bsc-out.expected | 12 +++ .../primtcons/ExpSizeOf_Let_WithCtx.bs | 10 +++ .../primtcons/ExpSizeOf_StringOf_NoCtx.bs | 12 +++ ...pSizeOf_StringOf_NoCtx.bs.bsc-out.expected | 12 +++ .../primtcons/ExpSizeOf_StringOf_WithCtx.bs | 12 +++ .../primtcons/ExpSizeOf_TypedExpr_NoCtx.bs | 9 ++ ...SizeOf_TypedExpr_NoCtx.bs.bsc-out.expected | 12 +++ .../primtcons/ExpSizeOf_TypedExpr_WithCtx.bs | 7 ++ .../primtcons/ExpSizeOf_ValueOf_NoCtx.bs | 12 +++ ...xpSizeOf_ValueOf_NoCtx.bs.bsc-out.expected | 12 +++ .../primtcons/ExpSizeOf_ValueOf_WithCtx.bs | 12 +++ .../primtcons/ExpSizeOf_VectorIfc.bsv | 27 ++++++ .../primtcons/ValueOf_KindMismatch_Arity.bs | 4 + .../primtcons/ValueOf_KindMismatch_Res.bs | 4 + .../bsc.typechecker/primtcons/primtcons.exp | 87 ++++++++++++++++++- .../typeclasses/ATFFieldUnifyError.bs | 25 ++++++ .../ATFFieldUnifyError.bs.bsc-out.expected | 10 +++ .../typeclasses/ATFFieldUnifyHKError.bs | 18 ++++ .../ATFFieldUnifyHKError.bs.bsc-out.expected | 10 +++ .../typeclasses/ATFPolyDataWidth.bs | 7 +- .../typeclasses/ATFUnifyError.bs | 7 +- .../ATFUnifyError.bs.bsc-out.expected | 5 +- .../typeclasses/ATFUnifyHKError.bs | 7 +- .../ATFUnifyHKError.bs.bsc-out.expected | 5 +- .../typeclasses/typeclasses.exp | 6 ++ 39 files changed, 672 insertions(+), 18 deletions(-) create mode 100644 testsuite/bsc.typechecker/primtcons/CExtendATF.bsv create mode 100644 testsuite/bsc.typechecker/primtcons/CExtendATFExplicit.bsv create mode 100644 testsuite/bsc.typechecker/primtcons/CExtendSynonym.bsv create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_BS.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Minimal.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_WithCtx.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ExpSizeOf_VectorIfc.bsv create mode 100644 testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Arity.bs create mode 100644 testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Res.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs.bsc-out.expected create mode 100644 testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs create mode 100644 testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs.bsc-out.expected diff --git a/src/comp/CtxRed.hs b/src/comp/CtxRed.hs index 13b0ea91e..5b35fd549 100644 --- a/src/comp/CtxRed.hs +++ b/src/comp/CtxRed.hs @@ -385,12 +385,16 @@ ctxRedCQType' isInstHead cqt = do -- (and do it here, after "convCQType", so that "expTFun" sees -- the qualified types) (qs, t) <- if isInstHead - then do -- XXX disable expanding of type synonyms until - -- XXX failures with TLM instances are resolved - -- XXX (vqs_extra, t1) <- expTFun t0 (expandSyn t0) - (vqs_extra, t1) <- expTFun t0 + then do (vqs_extra, t1) <- expTFun (expandSyn t0) let qs_extra = map toPredWithPositions vqs_extra - return (qs0 ++ qs_extra, t1) + -- Use the expanded type t1 only if expTFun actually + -- found something to expand (i.e. generated predicates). + -- Otherwise keep the original t0. + -- XXX we should probably be unconditionally expanding synonymns + -- here and in tiField1, but there is existing code that relies on + -- the current behavior, so changing this requires more thought. + let t' = if null vqs_extra then t0 else t1 + return (qs0 ++ qs_extra, t') else return (qs0, t0) -- construct the predicates and try to reduce them diff --git a/src/comp/TCheck.hs b/src/comp/TCheck.hs index ca4fd6488..cd876bcf3 100644 --- a/src/comp/TCheck.hs +++ b/src/comp/TCheck.hs @@ -2411,7 +2411,14 @@ tiExpl''' as0 i sc alts me (oqt@(oqs :=> ot), vts) = do -- type functions like SizeOf could have crept into the predicates -- via unification, so we expand them out so that they can be satisfied - ps <- concatMapM (expTConPred . expandSynVPred) ps0 + ps1 <- concatMapM (expTConPred . expandSynVPred) ps0 + + -- Expand type synonyms and type functions in the declared type to generate + -- implicit class predicates (e.g. SizeOf a generates Bits a n). + s_ot <- getSubst + let ot_expanded = expandSyn (apSub s_ot ot) + (ot_ps, _) <- expTFun ot_expanded + let ps = ps1 ++ ot_ps satTraceM ("tiExpl " ++ ppReadable i ++ " ps: " ++ ppReadable ps) diff --git a/testsuite/bsc.typechecker/primtcons/CExtendATF.bsv b/testsuite/bsc.typechecker/primtcons/CExtendATF.bsv new file mode 100644 index 000000000..e1c8fa619 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/CExtendATF.bsv @@ -0,0 +1,64 @@ +// A variant of CExtendSynonym that puts a type function (here a user-defined +// ATF, 'IdW') into the id-type synonyms, so that expanding the synonyms in the +// instance head *does* reveal a type function. That forces the conditional +// synonym expansion in 'CtxRed.ctxRedCQType'' to fire (unlike CExtendSynonym, +// where the plain synonyms are left unexpanded), which re-introduces the +// dangling 'addr_size' parameter and makes typecheck fail with T0035. +// +// This is the case that is *still broken* -- see the XXX in ctxRedCQType' and +// GitHub Issue #311 (and bsc-contrib PR 46, which worked around the analogous +// AMBA_TLM failure by adding explicit method types). CExtendATFExplicit.bsv +// shows that adding explicit types makes it compile, which suggests the +// problem is one of inference ordering rather than anything fundamental. +// The same failure occurs with the builtin type function SizeOf in place of +// the ATF 'IdW'. + +function Bit#(m) zExtend(Bit#(n) value) + provisos(Add#(n,m,k)); + Bit#(k) out = zeroExtend(value); + if (valueOf(m) == 0) + return ?; + else + return out[valueOf(m) - 1:0]; +endfunction + +function a cExtend(b value) + provisos(Bits#(a, sa), Bits#(b, sb)); + let out = unpack(zExtend(pack(value))); + return out; +endfunction + +// A user-defined ATF: IdW#(Bit#(n)) = n (i.e. it plays the role of SizeOf). +typeclass HasIdW#(type t, numeric type n) dependencies (t determines n); + type IdW#(type t) = n; +endtypeclass + +instance HasIdW#(Bit#(n), n); +endinstance + +`define TLM_PRM_DCL numeric type id_size, \ + numeric type addr_size + +`define TLM_PRM id_size, \ + addr_size + +typedef Bit#(IdW#(Bit#(id_size))) TLMId#(`TLM_PRM_DCL); +typedef Bit#(IdW#(Bit#(id_size))) AxiId#(`TLM_PRM_DCL); + +typedef struct { + AxiId#(`TLM_PRM) id; + } AxiAddrCmd#(`TLM_PRM_DCL); + +function TLMId#(`TLM_PRM) fromAxiId(AxiId#(`TLM_PRM) id); + return cExtend(id); +endfunction + +typeclass BusPayload#(type a, type b) dependencies(a determines b); + function b getId(a payload); +endtypeclass + +instance BusPayload#(AxiAddrCmd#(`TLM_PRM), TLMId#(`TLM_PRM)); + function getId(payload); + return fromAxiId(payload.id); + endfunction +endinstance diff --git a/testsuite/bsc.typechecker/primtcons/CExtendATFExplicit.bsv b/testsuite/bsc.typechecker/primtcons/CExtendATFExplicit.bsv new file mode 100644 index 000000000..3229e2c69 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/CExtendATFExplicit.bsv @@ -0,0 +1,55 @@ +// As CExtendATF.bsv, but with an explicit type on the 'getId' method. With +// the explicit type, typecheck succeeds despite the ATF-triggered synonym +// expansion in the instance head. This is the workaround used in bsc-contrib +// PR 46, and it shows that the CExtendATF failure is not fundamental (see the +// XXX in CtxRed.ctxRedCQType' and GitHub Issue #311). + +function Bit#(m) zExtend(Bit#(n) value) + provisos(Add#(n,m,k)); + Bit#(k) out = zeroExtend(value); + if (valueOf(m) == 0) + return ?; + else + return out[valueOf(m) - 1:0]; +endfunction + +function a cExtend(b value) + provisos(Bits#(a, sa), Bits#(b, sb)); + let out = unpack(zExtend(pack(value))); + return out; +endfunction + +// A user-defined ATF: IdW#(Bit#(n)) = n (i.e. it plays the role of SizeOf). +typeclass HasIdW#(type t, numeric type n) dependencies (t determines n); + type IdW#(type t) = n; +endtypeclass + +instance HasIdW#(Bit#(n), n); +endinstance + +`define TLM_PRM_DCL numeric type id_size, \ + numeric type addr_size + +`define TLM_PRM id_size, \ + addr_size + +typedef Bit#(IdW#(Bit#(id_size))) TLMId#(`TLM_PRM_DCL); +typedef Bit#(IdW#(Bit#(id_size))) AxiId#(`TLM_PRM_DCL); + +typedef struct { + AxiId#(`TLM_PRM) id; + } AxiAddrCmd#(`TLM_PRM_DCL); + +function TLMId#(`TLM_PRM) fromAxiId(AxiId#(`TLM_PRM) id); + return cExtend(id); +endfunction + +typeclass BusPayload#(type a, type b) dependencies(a determines b); + function b getId(a payload); +endtypeclass + +instance BusPayload#(AxiAddrCmd#(`TLM_PRM), TLMId#(`TLM_PRM)); + function TLMId#(`TLM_PRM) getId(AxiAddrCmd#(`TLM_PRM) payload); + return fromAxiId(payload.id); + endfunction +endinstance diff --git a/testsuite/bsc.typechecker/primtcons/CExtendSynonym.bsv b/testsuite/bsc.typechecker/primtcons/CExtendSynonym.bsv new file mode 100644 index 000000000..4e47ea575 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/CExtendSynonym.bsv @@ -0,0 +1,55 @@ +// Reduced version of the bsc-contrib AMBA_TLM library (see bsc-contrib PR 46). +// Check that we can use type synonyms in instance heads. The synonyms 'TLMId' +// and 'AxiId' drop the 'addr_size' parameter; expanding them fully in the +// instance head would leave 'addr_size' dangling and break unification. This +// exercises the (now conditional) synonym expansion in CtxRed.ctxRedCQType' -- +// see the XXX there and GitHub Issue #311. Because these synonyms contain no +// type function, the conditional expansion leaves them alone, so this compiles; +// bsc-contrib PR 46 added explicit method types to work around the earlier +// (unconditional-expansion) failure, and those are no longer needed here. +// CExtendATF.bsv shows a variant that *does* still fail, because it puts a type +// function in the synonyms and so triggers the expansion. + +function Bit#(m) zExtend(Bit#(n) value) + provisos(Add#(n,m,k)); + Bit#(k) out = zeroExtend(value); + if (valueOf(m) == 0) + return ?; + else + return out[valueOf(m) - 1:0]; +endfunction + +function a cExtend(b value) + provisos(Bits#(a, sa), Bits#(b, sb)); + + let out = unpack(zExtend(pack(value))); + + return out; +endfunction + +`define TLM_PRM_DCL numeric type id_size, \ + numeric type addr_size + +`define TLM_PRM id_size, \ + addr_size + +typedef Bit#(id_size) TLMId#(`TLM_PRM_DCL); +typedef Bit#(id_size) AxiId#(`TLM_PRM_DCL); + +typedef struct { + AxiId#(`TLM_PRM) id; + } AxiAddrCmd#(`TLM_PRM_DCL); + +function TLMId#(`TLM_PRM) fromAxiId(AxiId#(`TLM_PRM) id); + return cExtend(id); +endfunction + +typeclass BusPayload#(type a, type b) dependencies(a determines b); + function b getId(a payload); +endtypeclass + +instance BusPayload#(AxiAddrCmd#(`TLM_PRM), TLMId#(`TLM_PRM)); + function getId(payload); + return fromAxiId(payload.id); + endfunction +endinstance diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_BS.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_BS.bs new file mode 100644 index 000000000..87f0d453a --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_BS.bs @@ -0,0 +1,20 @@ +package ExpSizeOf_FieldSyn_BS where + +-- Classic syntax version of ExpSizeOf_FieldSyn. +-- A struct with a field whose type uses SizeOf through a synonym chain. + +type T t = UInt (S t) +type S t = SizeOf t + +struct Node dataType = + dat :: dataType + unused :: T dataType + deriving (Bits, Eq) + +{-# synthesize sysExpSizeOf_FieldSyn_BS #-} +sysExpSizeOf_FieldSyn_BS :: Module Empty +sysExpSizeOf_FieldSyn_BS = module + r_node :: Reg (Node (UInt 3)) <- mkRegU + r_data :: Reg (UInt 3) <- mkRegU + rules + when True ==> r_data := r_node.dat diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Minimal.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Minimal.bs new file mode 100644 index 000000000..ae7c63d00 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Minimal.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_FieldSyn_Minimal where + +-- Minimal reproduction: a struct with a field type that uses SizeOf +-- through a type synonym. Without expanding synonyms in ctxRedCQType, the +-- needed Bits context is not injected into the derived Generic instance, and +-- that instance then fails to typecheck -- i.e. the failure is a compile +-- error, so compile_pass is a sufficient regression guard here. + +type S t = SizeOf t + +struct Foo a = + x :: Bit (S a) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs new file mode 100644 index 000000000..ae2f9635b --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs @@ -0,0 +1,25 @@ +package ExpSizeOf_FieldSyn_Unbound_NoCtx where + +-- A struct field whose type uses SizeOf through a synonym, where the type +-- variable is *not* a parameter of the struct. Because the variable is +-- unbound in the struct type, the field's implicit Bits context cannot be +-- satisfied by the struct itself, so the field must declare it explicitly. +-- Here it does not, so typecheck reports the missing context (T0030). +-- (GitHub Issues #890 and #310: the field's context requirement is not +-- wrongly exempted here, despite the XXX in TCheck.tiField1.) +-- +-- Two T0030 errors are reported, both during typecheck of the definitions +-- auto-derived for the struct: the PrimMakeUninitialized and +-- PrimMakeUndefined instances for the wrapper struct generated for the +-- polymorphic field, and the Generic instance's from/to methods, each bind +-- the field and so introduce the unsatisfiable Bits proviso. That yields +-- four identical errors, deduplicated (by the nub in TypeCheck.tiDefns) to +-- two distinct texts: the bindings of the wrapper's generated field id have +-- no source position ("Unknown position"), while Generic's 'to' constructs +-- the struct with the source 'sfield' id and so carries its position. + +type T t = UInt (S t) +type S t = SizeOf t + +struct MyS = + sfield :: T dataType diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..e7669cd7b --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_NoCtx.bs.bsc-out.expected @@ -0,0 +1,23 @@ +checking package dependencies +compiling ExpSizeOf_FieldSyn_Unbound_NoCtx.bs +Error: Unknown position: (T0030) + The contexts for this expression are too general. + Given type: + ExpSizeOf_FieldSyn_Unbound_NoCtx.T a__ + The following contexts are needed: + Prelude.Bits a__ b__ + Introduced at the following locations: + "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 12 + The type variables are from the following positions: + "b__" at "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 12 +Error: "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 2: (T0030) + The contexts for this expression are too general. + Given type: + ExpSizeOf_FieldSyn_Unbound_NoCtx.T a__ + The following contexts are needed: + Prelude.Bits a__ b__ + Introduced at the following locations: + "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 12 + The type variables are from the following positions: + "a__" at "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 2 + "b__" at "ExpSizeOf_FieldSyn_Unbound_NoCtx.bs", line 25, column 12 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_WithCtx.bs new file mode 100644 index 000000000..223ca6012 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Unbound_WithCtx.bs @@ -0,0 +1,11 @@ +package ExpSizeOf_FieldSyn_Unbound_WithCtx where + +-- As ExpSizeOf_FieldSyn_Unbound_NoCtx, but the field declares the Bits +-- context that its SizeOf-using type requires, so typecheck succeeds. +-- (GitHub Issues #890 and #310) + +type T t = UInt (S t) +type S t = SizeOf t + +struct MyS = + sfield :: (Bits dataType sz) => T dataType diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs new file mode 100644 index 000000000..2b39de54f --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs @@ -0,0 +1,19 @@ +package ExpSizeOf_FieldSyn_Use_NoCtx where + +-- Reading a struct field whose type uses SizeOf through a synonym chain +-- requires a Bits context on the struct's type parameter. The field type +-- 'T a' expands to 'UInt (SizeOf a)', and reading the field during typecheck +-- introduces the implicit 'Bits a' context. Here it is not provided, so +-- typecheck reports the missing context (T0030), confirming that the field's +-- context requirement is handled during typecheck. (GitHub Issue #890) + +type T t = UInt (S t) +type S t = SizeOf t + +struct Node dataType = + dat :: dataType + wide :: T dataType + deriving (Bits, Eq) + +fnNeedsCtx :: Node a -> Bool +fnNeedsCtx n = n.wide == 0 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..a854839a6 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_NoCtx.bs.bsc-out.expected @@ -0,0 +1,12 @@ +checking package dependencies +compiling ExpSizeOf_FieldSyn_Use_NoCtx.bs +Error: "ExpSizeOf_FieldSyn_Use_NoCtx.bs", line 18, column 0: (T0030) + The contexts for this expression are too general. + Given type: + ExpSizeOf_FieldSyn_Use_NoCtx.Node a -> Prelude.Bool + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "ExpSizeOf_FieldSyn_Use_NoCtx.bs", line 15, column 10 + The type variables are from the following positions: + "a__" at "ExpSizeOf_FieldSyn_Use_NoCtx.bs", line 15, column 10 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_WithCtx.bs new file mode 100644 index 000000000..490091a50 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_FieldSyn_Use_WithCtx.bs @@ -0,0 +1,15 @@ +package ExpSizeOf_FieldSyn_Use_WithCtx where + +-- As ExpSizeOf_FieldSyn_Use_NoCtx, but with the explicit Bits context that +-- reading the field requires, so typecheck succeeds. (GitHub Issue #890) + +type T t = UInt (S t) +type S t = SizeOf t + +struct Node dataType = + dat :: dataType + wide :: T dataType + deriving (Bits, Eq) + +fnNeedsCtx :: (Bits a sa) => Node a -> Bool +fnNeedsCtx n = n.wide == 0 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs new file mode 100644 index 000000000..f746af2c4 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_Let_NoCtx where + +-- A let binding whose type annotation contains SizeOf requires a Bits +-- context: expanding the SizeOf in the declared type introduces an implicit +-- Bits context, which must be provided by an explicit context on the +-- enclosing definition. Here none is given, so typecheck reports the +-- missing context (T0030). (GitHub Issue #890) + +foo :: a -> String +foo _ = let x :: Bit (SizeOf a) + x = _ + in printType $ typeOf $ x diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..bacb7541a --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_NoCtx.bs.bsc-out.expected @@ -0,0 +1,12 @@ +checking package dependencies +compiling ExpSizeOf_Let_NoCtx.bs +Error: "ExpSizeOf_Let_NoCtx.bs", line 9, column 0: (T0030) + The contexts for this expression are too general. + Given type: + a -> Prelude.String + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "ExpSizeOf_Let_NoCtx.bs", line 10, column 22 + The type variables are from the following positions: + "a__" at "ExpSizeOf_Let_NoCtx.bs", line 10, column 22 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_WithCtx.bs new file mode 100644 index 000000000..ae21abb3f --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_Let_WithCtx.bs @@ -0,0 +1,10 @@ +package ExpSizeOf_Let_WithCtx where + +-- With an explicit Bits context on the enclosing definition, the implicit +-- Bits context introduced by the SizeOf in the let binding's declared type +-- is satisfied, so this compiles. (GitHub Issue #890) + +foo :: (Bits a sz) => a -> String +foo _ = let x :: Bit (SizeOf a) + x = _ + in printType $ typeOf $ x diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs new file mode 100644 index 000000000..3f09c2ff7 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_StringOf_NoCtx where + +data Thing = Thing (UInt 42) deriving (Bits) + +foo :: a -> String +foo _ = stringOf (TNumToStr (SizeOf a)) + +{-# synthesize main #-} +main :: Module Empty +main = module + rules + "asdf": when True ==> $display (foo $ Thing _) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..adfc6019e --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_NoCtx.bs.bsc-out.expected @@ -0,0 +1,12 @@ +checking package dependencies +compiling ExpSizeOf_StringOf_NoCtx.bs +Error: "ExpSizeOf_StringOf_NoCtx.bs", line 5, column 0: (T0030) + The contexts for this expression are too general. + Given type: + a -> Prelude.String + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "ExpSizeOf_StringOf_NoCtx.bs", line 6, column 29 + The type variables are from the following positions: + "a__" at "ExpSizeOf_StringOf_NoCtx.bs", line 6, column 29 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_WithCtx.bs new file mode 100644 index 000000000..c3692d8a3 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_StringOf_WithCtx.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_StringOf_WithCtx where + +data Thing = Thing (UInt 42) deriving (Bits) + +foo :: (Bits a sz) => a -> String +foo _ = stringOf (TNumToStr (SizeOf a)) + +{-# synthesize main #-} +main :: Module Empty +main = module + rules + "asdf": when True ==> $display (foo $ Thing _) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs new file mode 100644 index 000000000..9536b37b0 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs @@ -0,0 +1,9 @@ +package ExpSizeOf_TypedExpr_NoCtx where + +-- A type-annotated expression whose type mentions SizeOf introduces an +-- implicit Bits context, the same way 'valueOf'/'stringOf' do (they are +-- implemented using type-annotated expressions). Here the context is not +-- provided, so typecheck reports it (T0030). (GitHub Issue #890) + +foo :: a -> String +foo _ = printType $ typeOf (_ :: Bit (SizeOf a)) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..1aa140360 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_NoCtx.bs.bsc-out.expected @@ -0,0 +1,12 @@ +checking package dependencies +compiling ExpSizeOf_TypedExpr_NoCtx.bs +Error: "ExpSizeOf_TypedExpr_NoCtx.bs", line 8, column 0: (T0030) + The contexts for this expression are too general. + Given type: + a -> Prelude.String + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "ExpSizeOf_TypedExpr_NoCtx.bs", line 9, column 38 + The type variables are from the following positions: + "a__" at "ExpSizeOf_TypedExpr_NoCtx.bs", line 9, column 38 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_WithCtx.bs new file mode 100644 index 000000000..ce6dd6b4c --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_TypedExpr_WithCtx.bs @@ -0,0 +1,7 @@ +package ExpSizeOf_TypedExpr_WithCtx where + +-- With an explicit Bits context, the SizeOf in a type-annotated expression +-- can be reduced during typecheck. (GitHub Issue #890) + +foo :: (Bits a sz) => a -> String +foo _ = printType $ typeOf (_ :: Bit (SizeOf a)) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs new file mode 100644 index 000000000..227418f74 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_ValueOf_NoCtx where + +data Thing = Thing (UInt 42) deriving (Bits) + +foo :: a -> Integer +foo _ = valueOf (SizeOf a) + +{-# synthesize main #-} +main :: Module Empty +main = module + rules + "asdf": when True ==> $display (foo $ Thing _) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs.bsc-out.expected b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs.bsc-out.expected new file mode 100644 index 000000000..38ff942da --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_NoCtx.bs.bsc-out.expected @@ -0,0 +1,12 @@ +checking package dependencies +compiling ExpSizeOf_ValueOf_NoCtx.bs +Error: "ExpSizeOf_ValueOf_NoCtx.bs", line 5, column 0: (T0030) + The contexts for this expression are too general. + Given type: + a -> Prelude.Integer + The following contexts are needed: + Prelude.Bits a a__ + Introduced at the following locations: + "ExpSizeOf_ValueOf_NoCtx.bs", line 6, column 17 + The type variables are from the following positions: + "a__" at "ExpSizeOf_ValueOf_NoCtx.bs", line 6, column 17 diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_WithCtx.bs b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_WithCtx.bs new file mode 100644 index 000000000..e1f08665d --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_ValueOf_WithCtx.bs @@ -0,0 +1,12 @@ +package ExpSizeOf_ValueOf_WithCtx where + +data Thing = Thing (UInt 42) deriving (Bits) + +foo :: (Bits a sz) => a -> Integer +foo _ = valueOf (SizeOf a) + +{-# synthesize main #-} +main :: Module Empty +main = module + rules + "asdf": when True ==> $display (foo $ Thing _) diff --git a/testsuite/bsc.typechecker/primtcons/ExpSizeOf_VectorIfc.bsv b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_VectorIfc.bsv new file mode 100644 index 000000000..03649e02c --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ExpSizeOf_VectorIfc.bsv @@ -0,0 +1,27 @@ +// GitHub Issue #313 (Bluespec Inc Bug 1917): a SizeOf in the length parameter +// of a Vector of subinterfaces confuses GenWrap's method-vs-subinterface +// determination, which happens before typecheck and so cannot reduce +// SizeOf#(Bit#(2)) to 2. BSC therefore treats 'example' as a method and +// requires its element type to be bitifiable. +// +// This is not fixed by the type-function expansion added in PR #916: the +// example still typechecks fine (see the companion compile_pass), but fails when +// synthesized (compile_verilog_fail_error, T0043). The test documents the +// current behavior; if #313 is fixed, this should become a compile_verilog_pass. + +import Vector::*; + +// Using 'SizeOf#(Bit#(2))' triggers the bug; 'typedef 2 Length' would not. +typedef SizeOf#(Bit#(2)) Length; + +typedef Bit#(1) Data; + +interface Example; + interface Vector#(Length, WriteOnly#(Data)) example; +endinterface + +(* synthesize *) +module mkExample (Example); + Vector#(Length, Reg#(Data)) ex <- replicateM(mkRegU); + interface example = ?; +endmodule diff --git a/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Arity.bs b/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Arity.bs new file mode 100644 index 000000000..a13e418c3 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Arity.bs @@ -0,0 +1,4 @@ +package ValueOf_KindMismatch_Arity where + +bar :: Integer +bar = valueOf (SizeOf Int) diff --git a/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Res.bs b/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Res.bs new file mode 100644 index 000000000..aa14a1bd9 --- /dev/null +++ b/testsuite/bsc.typechecker/primtcons/ValueOf_KindMismatch_Res.bs @@ -0,0 +1,4 @@ +package ValueOf_KindMismatch_Res where + +baz :: Integer +baz = valueOf Bool diff --git a/testsuite/bsc.typechecker/primtcons/primtcons.exp b/testsuite/bsc.typechecker/primtcons/primtcons.exp index 51712df07..ae2472ce2 100644 --- a/testsuite/bsc.typechecker/primtcons/primtcons.exp +++ b/testsuite/bsc.typechecker/primtcons/primtcons.exp @@ -18,8 +18,9 @@ compile_pass ExpSizeOf_Instances.bsv compile_pass ExpSizeOf_InstancesBase.bsv -# Test that SizeOf is expanded even when it's buried in a type synonym -compile_pass_bug ExpSizeOf_InstancesBaseSyn.bsv 1729 +# Test that SizeOf is expanded even when it's buried in a type synonym. +# This was Bluespec Inc Bug 1729 (also GitHub Issue #311). +compile_pass ExpSizeOf_InstancesBaseSyn.bsv # --------------- # Test that SizeOf introduced through the type of a field in a struct value @@ -32,6 +33,88 @@ compile_verilog_pass ExpSizeOf_Field.bsv # but after adding the normtypes pass (later replaced by extra normalization in expanded), # it succeeds. compile_verilog_pass ExpSizeOf_FieldSyn.bsv +compile_verilog_pass ExpSizeOf_FieldSyn_BS.bs + +# Minimal reproduction: without expanding the synonym in ctxRedCQType, the +# derived Generic instance fails to typecheck (the needed Bits context is not +# injected), so it fails to compile. A plain compile_pass is therefore a +# sufficient regression guard -- no intermediate dump is needed. +compile_pass ExpSizeOf_FieldSyn_Minimal.bs + +# Using a struct field whose type uses SizeOf through a synonym requires a Bits +# context on the struct's type parameter. The requirement is introduced during +# typecheck of the field access, so it must be provided (GitHub Issue #890). +compile_fail_error ExpSizeOf_FieldSyn_Use_NoCtx.bs T0030 +compare_file [make_bsc_output_name ExpSizeOf_FieldSyn_Use_NoCtx.bs] +compile_pass ExpSizeOf_FieldSyn_Use_WithCtx.bs + +# A struct field whose SizeOf-using type has a type variable that is not a +# parameter of the struct is not exempted from the Bits requirement: the field +# must declare the context explicitly (GitHub Issues #890 and #310). BSC +# reports two T0030 errors here, both from typecheck of the definitions +# auto-derived for the struct (PrimMakeUninitialized and PrimMakeUndefined for +# the generated wrapper struct for the polymorphic field, and Generic's +# from/to); the wrapper's generated field id has no source position, so those +# errors report "Unknown position". The expected output pins this so any +# change is detected. +compile_fail_error ExpSizeOf_FieldSyn_Unbound_NoCtx.bs T0030 2 +compare_file [make_bsc_output_name ExpSizeOf_FieldSyn_Unbound_NoCtx.bs] +compile_pass ExpSizeOf_FieldSyn_Unbound_WithCtx.bs + +# --------------- +# Test that type functions like SizeOf are expanded in explicitly-typed +# expressions, introducing the implicit contexts they require and reporting an +# error when those contexts are not provided (GitHub Issue #890). This covers +# 'valueOf', 'stringOf', type-annotated expressions, and explicitly-typed let +# bindings (valueOf and stringOf are themselves implemented using type-annotated +# expressions). + +# valueOf +compile_fail_error ExpSizeOf_ValueOf_NoCtx.bs T0030 +compare_file [make_bsc_output_name ExpSizeOf_ValueOf_NoCtx.bs] +compile_pass ExpSizeOf_ValueOf_WithCtx.bs + +# stringOf +compile_fail_error ExpSizeOf_StringOf_NoCtx.bs T0030 +compare_file [make_bsc_output_name ExpSizeOf_StringOf_NoCtx.bs] +compile_pass ExpSizeOf_StringOf_WithCtx.bs + +# type-annotated expression, e.g. '(_ :: Bit (SizeOf a))' +compile_fail_error ExpSizeOf_TypedExpr_NoCtx.bs T0030 +compare_file [make_bsc_output_name ExpSizeOf_TypedExpr_NoCtx.bs] +compile_pass ExpSizeOf_TypedExpr_WithCtx.bs + +# explicitly-typed let binding +compile_fail_error ExpSizeOf_Let_NoCtx.bs T0030 +compare_file [make_bsc_output_name ExpSizeOf_Let_NoCtx.bs] +compile_pass ExpSizeOf_Let_WithCtx.bs + +# Kind errors in valueOf type argument +compile_fail_error ValueOf_KindMismatch_Arity.bs T0025 +compile_fail_error ValueOf_KindMismatch_Res.bs T0026 + +# --------------- +# Type synonyms and type functions in instance heads +# (GitHub Issue #311, bsc-contrib PR 46) + +# Plain type synonyms in an instance head are left unexpanded, so this compiles +# without the explicit method types that bsc-contrib PR 46 previously needed. +compile_pass CExtendSynonym.bsv + +# A type function (here a user-defined ATF) in the instance-head synonyms forces +# the conditional expansion in ctxRedCQType', which re-introduces the dangling +# parameter and still fails -- unless explicit method types are given. This is +# the case that remains broken (GitHub Issue #311). +compile_fail_error CExtendATF.bsv T0035 +compile_pass CExtendATFExplicit.bsv + +# --------------- +# SizeOf in the length of a Vector of subinterfaces (GitHub Issue #313, +# Bluespec Inc Bug 1917). This is not fixed by PR #916: the example typechecks, +# but fails when synthesized, because GenWrap decides whether the field is a +# method or a subinterface before typecheck and cannot reduce the SizeOf. +compile_pass ExpSizeOf_VectorIfc.bsv +compile_verilog_fail_error ExpSizeOf_VectorIfc.bsv T0043 # --------------- diff --git a/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs new file mode 100644 index 000000000..440b5d381 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs @@ -0,0 +1,25 @@ +package ATFFieldUnifyError where + +-- Like ATFUnifyError, but the unification of a type function application with +-- a concrete type is forced by reading a struct field. Reading a field whose +-- type is 'Elem f' and assigning it to Bool requires 'Container f Bool', which +-- is not in scope, so typecheck reports the missing context (T0030). + +class Container f e | f -> e where + type Elem f = e + wrap :: e -> f + unwrap :: f -> e + +data Box a = Box a + +instance Container (Box a) a where + wrap = Box + unwrap (Box x) = x + +-- Reading a struct field whose type is Elem f, and assigning to Bool, +-- requires Container f Bool which is not in scope. +struct Holder f = + val :: Elem f + +getBool :: Holder a -> Bool +getBool h = h.val diff --git a/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs.bsc-out.expected b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs.bsc-out.expected new file mode 100644 index 000000000..705fc1423 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyError.bs.bsc-out.expected @@ -0,0 +1,10 @@ +checking package dependencies +compiling ATFFieldUnifyError.bs +Error: "ATFFieldUnifyError.bs", line 24, column 0: (T0030) + The contexts for this expression are too general. + Given type: + ATFFieldUnifyError.Holder a -> Prelude.Bool + The following contexts are needed: + ATFFieldUnifyError.Container a Prelude.Bool + Introduced at the following locations: + "ATFFieldUnifyError.bs", line 25, column 12 diff --git a/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs new file mode 100644 index 000000000..ed9bf01fa --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs @@ -0,0 +1,18 @@ +package ATFFieldUnifyHKError where + +-- Like ATFUnifyHKError, but the unification of a higher-kinded type function +-- application with a concrete type constructor is forced by reading a struct +-- field. Reading a field whose type uses the higher-kinded ATF (Elem a), and +-- assigning it to Foo Maybe, requires Container a Maybe which is not in scope, +-- so typecheck reports the missing context (T0030). + +class (Container :: * -> (* -> *) -> *) a s | a -> s where + type Elem a = s + +data Foo f = Foo (f Bool) + +struct Holder a = + val :: Foo (Elem a) + +getMaybe :: Holder a -> Foo Maybe +getMaybe h = h.val diff --git a/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs.bsc-out.expected b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs.bsc-out.expected new file mode 100644 index 000000000..bed5d2fb7 --- /dev/null +++ b/testsuite/bsc.typechecker/typeclasses/ATFFieldUnifyHKError.bs.bsc-out.expected @@ -0,0 +1,10 @@ +checking package dependencies +compiling ATFFieldUnifyHKError.bs +Error: "ATFFieldUnifyHKError.bs", line 17, column 0: (T0030) + The contexts for this expression are too general. + Given type: + ATFFieldUnifyHKError.Holder a -> ATFFieldUnifyHKError.Foo Prelude.Maybe + The following contexts are needed: + ATFFieldUnifyHKError.Container a Prelude.Maybe + Introduced at the following locations: + "ATFFieldUnifyHKError.bs", line 18, column 13 diff --git a/testsuite/bsc.typechecker/typeclasses/ATFPolyDataWidth.bs b/testsuite/bsc.typechecker/typeclasses/ATFPolyDataWidth.bs index 6e66f7c25..679fec40c 100644 --- a/testsuite/bsc.typechecker/typeclasses/ATFPolyDataWidth.bs +++ b/testsuite/bsc.typechecker/typeclasses/ATFPolyDataWidth.bs @@ -31,11 +31,12 @@ mkEncoded val = let raw = toBit val in Encoded raw (zeroExtend raw) --- Polymorphic pattern match -getRaw :: Encoded f -> Bit (Width f) +-- Polymorphic pattern match: need HasWidth context because Width f +-- in the return type generates an implicit HasWidth predicate. +getRaw :: (HasWidth f n) => Encoded f -> Bit (Width f) getRaw (Encoded r _) = r -getExtended :: Encoded f -> Bit (TAdd (Width f) 1) +getExtended :: (HasWidth f n) => Encoded f -> Bit (TAdd (Width f) 1) getExtended (Encoded _ e) = e -- Concrete: Width Byte = 8, TAdd 8 1 = 9 diff --git a/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs b/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs index eac7a1e73..d8a6f808c 100644 --- a/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs +++ b/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs @@ -1,7 +1,10 @@ package ATFUnifyError where --- Test that unification of two different type function applications fails --- when they cannot be proven equal. +-- Test that unifying a type function application (Elem a) with a concrete +-- type (Bool) requires the corresponding class context (Container a Bool). +-- Here it is missing, so typecheck reports it (T0030). The unification is +-- forced by giving 'id' the explicit type 'a -> Elem a -> Bool'. +-- (See ATFFieldUnifyError for the same check via struct field access.) class Container f e | f -> e where type Elem f = e diff --git a/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs.bsc-out.expected b/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs.bsc-out.expected index 5fbec0d16..f23e0e286 100644 --- a/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs.bsc-out.expected +++ b/testsuite/bsc.typechecker/typeclasses/ATFUnifyError.bs.bsc-out.expected @@ -1,10 +1,11 @@ checking package dependencies compiling ATFUnifyError.bs -Error: "ATFUnifyError.bs", line 18, column 0: (T0030) +Error: "ATFUnifyError.bs", line 21, column 0: (T0030) The contexts for this expression are too general. Given type: a -> ATFUnifyError.Elem a -> Prelude.Bool The following contexts are needed: ATFUnifyError.Container a Prelude.Bool Introduced at the following locations: - "ATFUnifyError.bs", line 19, column 9 + "ATFUnifyError.bs", line 21, column 13 + "ATFUnifyError.bs", line 22, column 9 diff --git a/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs b/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs index ff3a22444..0bfcdb188 100644 --- a/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs +++ b/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs @@ -1,6 +1,11 @@ package ATFUnifyHKError where --- Test that higher-kinded type function constraints fail properly. +-- Test that unifying a higher-kinded type function application (Elem a, +-- of kind * -> *) with a concrete type constructor (Maybe) requires the +-- corresponding class context (Container a Maybe). Here it is missing, so +-- typecheck reports it (T0030). The unification is forced by giving 'id' +-- the explicit type 'a -> Foo (Elem a) -> Foo Maybe'. +-- (See ATFFieldUnifyHKError for the same check via struct field access.) class (Container :: * -> (* -> *) -> *) a s | a -> s where type Elem a = s diff --git a/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs.bsc-out.expected b/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs.bsc-out.expected index 83bf6d1a4..ac04359d7 100644 --- a/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs.bsc-out.expected +++ b/testsuite/bsc.typechecker/typeclasses/ATFUnifyHKError.bs.bsc-out.expected @@ -1,6 +1,6 @@ checking package dependencies compiling ATFUnifyHKError.bs -Error: "ATFUnifyHKError.bs", line 10, column 0: (T0030) +Error: "ATFUnifyHKError.bs", line 15, column 0: (T0030) The contexts for this expression are too general. Given type: a -> ATFUnifyHKError.Foo (ATFUnifyHKError.Elem a) -> ATFUnifyHKError.Foo @@ -8,4 +8,5 @@ Error: "ATFUnifyHKError.bs", line 10, column 0: (T0030) The following contexts are needed: ATFUnifyHKError.Container a Prelude.Maybe Introduced at the following locations: - "ATFUnifyHKError.bs", line 11, column 9 + "ATFUnifyHKError.bs", line 15, column 18 + "ATFUnifyHKError.bs", line 16, column 9 diff --git a/testsuite/bsc.typechecker/typeclasses/typeclasses.exp b/testsuite/bsc.typechecker/typeclasses/typeclasses.exp index 709629a59..c3572f55f 100644 --- a/testsuite/bsc.typechecker/typeclasses/typeclasses.exp +++ b/testsuite/bsc.typechecker/typeclasses/typeclasses.exp @@ -134,6 +134,12 @@ compile_fail_error ATFUnifyError.bs T0030 compare_file ATFUnifyError.bs.bsc-out compile_fail_error ATFUnifyHKError.bs T0030 compare_file ATFUnifyHKError.bs.bsc-out +# Same checks as ATFUnify{,HK}Error, but forcing the unification via struct +# field access instead of via 'id' +compile_fail_error ATFFieldUnifyError.bs T0030 +compare_file ATFFieldUnifyError.bs.bsc-out +compile_fail_error ATFFieldUnifyHKError.bs T0030 +compare_file ATFFieldUnifyHKError.bs.bsc-out compile_fail_error ATFAmbig.bs T0079 compare_file ATFAmbig.bs.bsc-out compile_fail_error ATFNameClashTwoClasses.bs T0011