Support splitting up struct method parameters into multiple input ports

src/Libraries/Base1/Prelude.bs

@@ -94,7 +94,7 @@ package Prelude(
         primCharToString,
         primUIntBitsToInteger, primIntBitsToInteger,
 
-        ($), (∘), id, const, constFn, flip, while, curry, uncurry, asTypeOf,
+        ($), (∘), id, const, constFn, flip, while, curry, uncurry, Curry(..), asTypeOf,
         liftM, liftM2, bindM,
 
         (<+>), rJoin,
@@ -171,6 +171,7 @@ package Prelude(
         Tuple6, tuple6, Has_tpl_6(..),
         Tuple7, tuple7, Has_tpl_7(..),
         Tuple8, tuple8, Has_tpl_8(..),
+        AppendTuple(..), AppendTuple'(..), TupleSize(..),
 
         -- lists required for desugaring
         List(..),
@@ -253,7 +254,10 @@ package Prelude(
         -- Generics
         Generic(..), Conc(..), ConcPrim(..), ConcPoly(..),
         Meta(..), MetaData(..), StarArg(..), NumArg(..), StrArg(..), ConArg(..),
-        MetaConsNamed(..), MetaConsAnon(..), MetaField(..)
+        MetaConsNamed(..), MetaConsAnon(..), MetaField(..),
+
+        primMethod, WrapField(..), WrapMethod(..), WrapPorts(..),
+        Port(..), SplitPorts(..)
         ) where
 
 infixr  0 $
@@ -2589,6 +2593,23 @@ curry f x y = f (x, y)
 uncurry :: (a -> b -> c) -> ((a, b) -> c)
 uncurry f (x, y) = f x y
 
+-- Polymorphic, N-argument version of curry/uncurry
+class Curry f g | f -> g where
+  curryN :: f -> g
+  uncurryN :: g -> f
+
+instance (Curry (b -> c) d) => Curry ((a, b) -> c) (a -> d) where
+  curryN f x = curryN $ \y -> f (x, y)
+  uncurryN f (x, y) = uncurryN (f x) y
+
+instance Curry (() -> a) a where
+  curryN f = f ()
+  uncurryN f _ = f
+
+instance Curry (a -> b) (a -> b) where
+  curryN = id
+  uncurryN = id
+
 --@ Constant function
 --@ \index{const@\te{const} (Prelude function)}
 --@ \begin{libverbatim}
@@ -3372,6 +3393,43 @@ tuple7 a b c d e f g = (a,b,c,d,e,f,g)
 tuple8 :: a -> b -> c -> d -> e -> f -> g -> h   -> Tuple8 a b c d e f g h
 tuple8 a b c d e f g h = (a,b,c,d,e,f,g,h)
 
+class AppendTuple a b c | a b -> c where
+  appendTuple :: a -> b -> c
+  splitTuple :: c -> (a, b)
+
+instance AppendTuple a () a where
+  appendTuple x _ = x
+  splitTuple x = (x, ())
+
+-- The above instance should take precedence over the other cases that assume
+-- b is non-unit. To avoid overlapping instances, the below are factored out as
+-- a seperate type class:
+instance (AppendTuple' a b c) => AppendTuple a b c where
+  appendTuple = appendTuple'
+  splitTuple = splitTuple'
+
+class AppendTuple' a b c | a b -> c where
+  appendTuple' :: a -> b -> c
+  splitTuple' :: c -> (a, b)
+
+instance AppendTuple' () a a where
+  appendTuple' _ = id
+  splitTuple' x = ((), x)
+
+instance AppendTuple' a b (a, b) where
+  appendTuple' a b = (a, b)
+  splitTuple' = id
+
+instance (AppendTuple' a b c) => AppendTuple' (h, a) b (h, c) where
+  appendTuple' (x, y) z = (x, appendTuple' y z)
+  splitTuple' (x, y) = case splitTuple' y of
+    (w, z) -> ((x, w), z)
+
+class TupleSize a n | a -> n where {}
+instance TupleSize () 0 where {}
+instance TupleSize a 1 where {}
+instance (TupleSize b n) => TupleSize (a, b) (TAdd n 1) where {}
+
 -- FUNCTIONS TO REPLACE UNAVAILABLE INFIXES
 
 compose :: (b -> c) -> (a -> b) -> (a -> c)
@@ -4370,3 +4428,218 @@ data (MetaConsAnon :: $ -> # -> # -> *) name idx nfields = MetaConsAnon
 -- field) and index in the constructor's fields
 data (MetaField :: $ -> # -> *) name idx = MetaField
   deriving (FShow)
+
+
+-- Tag a method with metadata.
+-- Currently just the list of input port names.
+-- Should eventually include the output port names, when we support multiple output ports.
+primitive primMethod :: List String -> a -> a
+
+-- Convert bewtween a field in an interface that is being synthesized,
+-- and a field in the corresponding field in the generated wrapper interface.
+-- Also takes the name of the field for error reporting purposes.
+class (WrapField :: $ -> * -> * -> *) name f w | name f -> w where
+  -- Given a proxy value for the field name, and the values of the prefix and arg_names pragmas,
+  -- converts a synthesized interface field value to its wrapper interface field.
+  toWrapField :: StrArg name -> String -> List String -> f -> w
+
+  -- Given a proxy value for the field name, converts a wrapper interface field value
+  -- to its synthesized interface field.
+  fromWrapField :: StrArg name -> w -> f
+
+  -- Save the port types for a field in the wrapped interface, given the module name
+  -- and the prefix, arg_names and result pragmas.
+  saveFieldPortTypes :: StrArg name -> f -> Maybe Name__ -> String -> List String -> String -> Module ()
+
+instance (WrapMethod m w) => (WrapField name m w) where
+  toWrapField _ prefix names =
+    let baseNames = methodArgBaseNames (_ :: m) prefix names 1
+    in primMethod (inputPortNames (_ :: m) baseNames) ∘ toWrapMethod
+  fromWrapField _ = fromWrapMethod
+  saveFieldPortTypes _ _ modName prefix names =
+    let baseNames = methodArgBaseNames (_ :: m) prefix names 1
+    in saveMethodPortTypes (_ :: m) modName baseNames
+
+-- TODO: It doesn't seem possible to have a PrimAction field in a synthesized interface,
+-- but this case was being handled in GenWrap.
+instance WrapField name PrimAction PrimAction where
+  toWrapField _ _ _ = id
+  fromWrapField _ = id
+  saveFieldPortTypes _ _ _ _ _ _ = return ()
+
+instance WrapField name Clock Clock where
+  toWrapField _ _ _ = id
+  fromWrapField _ = id
+  saveFieldPortTypes _ _ _ _ _ _ = return ()
+
+instance WrapField name Reset Reset where
+  toWrapField _ _ _ = id
+  fromWrapField _ = id
+  saveFieldPortTypes _ _ _ _ _ _ = return ()
+
+instance (Bits a n) => WrapField name (Inout a) (Inout_ n) where
+  toWrapField _ _ _ = primInoutCast0
+  fromWrapField _ = primInoutUncast0
+  saveFieldPortTypes _ _ modName _ _ result = primSavePortType modName result $ typeOf (_ :: (Inout a))
+
+class WrapMethod m w | m -> w where
+  -- Convert a synthesized interface method to its wrapper interface method.
+  toWrapMethod :: m -> w
+
+  -- Convert a wrapper interface method to its synthesized interface method.
+  fromWrapMethod :: w -> m
+
+  -- 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
+
+  -- Save the port types for a method, given the module name, argument base names and result name.
+  saveMethodPortTypes :: m -> Maybe Name__ -> List String -> String -> Module ()
+
+instance (SplitPorts a p, TupleSize p n, WrapPorts p pb, WrapMethod b v, Curry (pb -> v) w) =>
+    WrapMethod (a -> b) w where
+  toWrapMethod f = curryN $ toWrapMethod ∘ f ∘ unsplitPorts ∘ unpackPorts
+  fromWrapMethod f = fromWrapMethod ∘ uncurryN f ∘ packPorts ∘ splitPorts
+
+  methodArgBaseNames _ prefix (Cons h t) i = Cons
+    -- arg_names can start with a digit
+    (if prefix == "" && not (isDigit $ stringHead h) then h else prefix +++ "_" +++ h)
+    (methodArgBaseNames (_ :: b) prefix t $ i + 1)
+  methodArgBaseNames _ prefix Nil i = Cons
+    (prefix +++ "_" +++ integerToString i)
+    (methodArgBaseNames (_ :: b) prefix Nil $ i + 1)
+
+  inputPortNames _ (Cons h t) = checkPortNames (_ :: a) h `listPrimAppend` inputPortNames (_ :: b) t
+  inputPortNames _ Nil = error "inputPortNames: empty arg names list"
+
+  saveMethodPortTypes _ modName (Cons h t) result = do
+    savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) h
+    saveMethodPortTypes (_ :: b) modName t result
+  saveMethodPortTypes _ _ Nil _ = error "saveMethodPortTypes: empty arg names list"
+
+instance (Bits a n) => WrapMethod (ActionValue a) (ActionValue_ n) where
+  toWrapMethod = toActionValue_
+  fromWrapMethod = fromActionValue_
+  methodArgBaseNames _ _ _ _ = Nil
+  inputPortNames _ _ = Nil
+  saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a)
+
+instance (Bits a n) => WrapMethod a (Bit n) where
+  toWrapMethod = pack
+  fromWrapMethod = unpack
+  methodArgBaseNames _ _ _ _ = Nil
+  inputPortNames _ _ = Nil
+  saveMethodPortTypes _ modName _ result = primSavePortType modName result $ typeOf (_ :: a)
+
+{-
+Eventually, we should support splitting multiple output ports.
+instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod (ActionValue a) (ActionValue pb) where
+  toWrapMethod = fmap packPorts
+  fromWrapMethod = fmap unpackPorts
+  outputPortNames _ base = checkPortNames (_ :: a) base
+  saveMethodPortTypes _ modName _ result =
+    savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) result
+
+instance (SplitPorts a p, TupleSize p n, WrapPorts p pb) => WrapMethod a pb where
+  toWrapMethod a = packPorts a
+  fromWrapMethod a = unpackPorts a
+  outputPortNames _ base = checkPortNames (_ :: a) base
+  saveMethodPortTypes _ modName _ result =
+    savePortTypes (_ :: p) modName $ checkPortNames (_ :: a) result
+-}
+
+class WrapPorts p pb | p -> pb where
+  -- Convert from a tuple of values to a tuple of bits.
+  packPorts :: p -> pb
+  -- Convert from a tuple of bits to a tuple of values.
+  unpackPorts :: pb -> p
+  -- Save the port types, given their names.
+  savePortTypes :: p -> Maybe Name__ -> List String -> Module ()
+
+instance (Bits a n, WrapPorts b bb) => WrapPorts (Port a, b) (Bit n, bb) where
+  packPorts (Port a, b) = (pack a, packPorts b)
+  unpackPorts (a, b) = (Port $ unpack a, unpackPorts b)
+  savePortTypes _ modName (Cons h t) = do
+    primSavePortType modName h $ typeOf (_ :: a)
+    savePortTypes (_ :: b) modName t
+  savePortTypes _ _ Nil = error "savePortTypes: empty port names list"
+
+instance (Bits a n) => WrapPorts (Port a) (Bit n) where
+  packPorts (Port a) = pack a
+  unpackPorts = Port ∘ unpack
+  savePortTypes _ modName (Cons h _) = primSavePortType modName h $ typeOf (_ :: a)
+  savePortTypes _ _ Nil = error "savePortTypes: empty port names list"
+
+instance WrapPorts () () where
+  packPorts _ = ()
+  unpackPorts _ = ()
+  savePortTypes _ _ _ = return ()
+
+-- Compute the list port names for type 'a' given a base name.
+-- Check that the number of port names matches the number of ports.
+-- This error should only occur if there is an error in a WrapPorts instance.
+checkPortNames :: (SplitPorts a p, TupleSize p n) => a -> String -> List String
+checkPortNames proxy base =
+  let pn = portNames proxy base
+  in
+    if listLength pn /= valueOf n
+    then error $ "SplitPorts: " +++ base +++ " has " +++ integerToString (valueOf n) +++
+      " ports, but " +++ integerToString (listLength pn) +++ " port names were given"
+    else pn
+
+class SplitPorts a p | a -> p where
+  -- Convert a value to a tuple of values corresponding to ports.
+  splitPorts :: a -> p
+  -- Combine a tuple of values corresponding to ports into a value.
+  unsplitPorts :: p -> a
+  -- Compute the list of port names for a type, given a base name.
+  -- This must be the same length as the tuple of values.
+  -- XXX it would be nice to use ListN here to enforce this, but it's not
+  -- available in the Prelude.
+  portNames :: a -> String -> List String
+
+data Port a = Port a
+  deriving (FShow)
+
+-- XXX if the default instance is the only one, then it gets inlined in CtxReduce
+-- and other instances for this class are ignored.
+instance SplitPorts () () where
+  splitPorts = id
+  unsplitPorts = id
+  portNames _ _ = Nil
+
+-- Default instance: don't split anything we don't know how to split.
+instance SplitPorts a (Port a) where
+  splitPorts = Port
+  unsplitPorts (Port a) = a
+  portNames _  base = Cons base Nil
+
+{-
+XXX Consider if we want to split tuples by default. This would change the current behavior,
+but might be a sensible one, especially if we support methods with multiple output ports.
+
+instance (SplitTuplePorts (a, b) r) => SplitPorts (a, b) r where
+  splitPorts = splitTuplePorts
+  unsplitPorts = unsplitTuplePorts
+  portNames = splitTuplePortNames 1
+
+class SplitTuplePorts a p | a -> p where
+  splitTuplePorts :: a -> p
+  unsplitTuplePorts :: p -> a
+  splitTuplePortNames :: Integer -> a -> String -> List String
+
+instance (SplitPorts a p, SplitTuplePorts b q, AppendTuple p q r) => SplitTuplePorts (a, b) r where
+  splitTuplePorts (a, b) = splitPorts a `appendTuple` splitTuplePorts b
+  unsplitTuplePorts x = case splitTuple x of
+    (a, b) -> (unsplitPorts a, unsplitTuplePorts b)
+  splitTuplePortNames i _ base =
+    portNames (_ :: a) (base +++ "_" +++ integerToString i) `listPrimAppend`
+    splitTuplePortNames (i + 1) (_ :: b) base
+
+instance (SplitPorts a p) => SplitTuplePorts a p where
+  splitTuplePorts = splitPorts
+  unsplitTuplePorts x = unsplitPorts x
+  splitTuplePortNames i _ base = portNames (_ :: a) $ base +++ "_" +++ integerToString i
+-}

src/Libraries/Base1/PreludeBSV.bsv

@@ -88,15 +88,17 @@ interface VRWireN#(numeric type n);
 endinterface
 
 // for addCFWire desugaring
+// This uses prim types like something coming from genwrap.
 module vMkRWire1(VRWireN#(1));
 
    (* hide *)
    VRWire#(Bit#(1)) _rw <- vMkRWire;
-   method wset(v);
-      return(toPrimAction(_rw.wset(v)));
-   endmethod
-   method wget = _rw.wget;
-   method whas = pack(_rw.whas);
+   function rw_wset(v);
+      return toPrimAction(_rw.wset(v));
+   endfunction
+   method wset = primMethod(Cons("v", Nil), rw_wset);
+   method wget = primMethod(Nil, _rw.wget);
+   method whas = primMethod(Nil, pack(_rw.whas));
 
 endmodule