[pull] main from B-Lang-org:main

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)

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

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)

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

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

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

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 }) =

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...