X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=8f1c3fd4d6e1a49326c2086cca2b756b8fc798ac;hb=b2e147bebb4ac8195971cd427903e53082f3bdf6;hp=88a8b1691846e3776fac6de47a52aeb3800b6f02;hpb=cd5b8d1205f3ef1aacd95b332c5e450121c01d5a;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 88a8b16..8f1c3fd 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -108,7 +108,7 @@ getPortMapEntry ::
   
 -- Accepts a port name and an argument to map to it.
 -- Returns the appropriate line for in the port map
-getPortMapEntry (Signal portname _) (Signal signame _) = 
+getPortMapEntry (Single (portname, _)) (Single (signame, _)) = 
   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
 expandExpr ::
   [(CoreBndr, SignalNameMap)] 
@@ -142,10 +142,10 @@ expandExpr binds lam@(Lam b expr) = do
           res_signal')
 
 expandExpr binds (Var id) =
-  return ([], [], [], Signal signal_id ty)
+  return ([], [], [], Single (signal_id, ty))
   where
     -- Lookup the id in our binds map
-    Signal signal_id ty = Maybe.fromMaybe
+    Single (signal_id, ty) = Maybe.fromMaybe
       (error $ "Argument " ++ getOccString id ++ "is unknown")
       (lookup id binds)
 
@@ -160,11 +160,17 @@ expandExpr binds l@(Let (NonRec b bexpr) expr) = do
     res_signals')
 
 expandExpr binds app@(App _ _) = do
-  let ((Var f), args) = collectArgs app
-  if isTupleConstructor f 
-    then
-      expandBuildTupleExpr binds args
-    else
+  -- Is this a data constructor application?
+  case CoreUtils.exprIsConApp_maybe app of
+    -- Is this a tuple construction?
+    Just (dc, args) -> if DataCon.isTupleCon dc 
+      then
+        expandBuildTupleExpr binds (dataConAppArgs dc args)
+      else
+        error "Data constructors other than tuples not supported"
+    otherise ->
+      -- Normal function application, should map to a component instantiation
+      let ((Var f), args) = collectArgs app in
       expandApplicationExpr binds (CoreUtils.exprType app) f args
 
 expandExpr binds expr@(Case (Var v) b _ alts) =
@@ -187,10 +193,9 @@ expandBuildTupleExpr ::
                                          -- See expandExpr
 expandBuildTupleExpr binds args = do
   -- Split the tuple constructor arguments into types and actual values.
-  let (_, vals) = splitTupleConstructorArgs args
   -- Expand each of the values in the tuple
   (signals_declss, statementss, arg_signalss, res_signals) <-
-    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
+    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) args
   if any (not . null) arg_signalss
     then error "Putting high order functions in tuples not supported"
     else
@@ -279,7 +284,7 @@ createAssocElems ::
   -> SignalNameMap   -- The signals to bind to it
   -> [AST.AssocElem]            -- The resulting port map lines
   
-createAssocElems (Signal port_id _) (Signal signal_id _) = 
+createAssocElems (Single (port_id, _)) (Single (signal_id, _)) = 
   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 
 createAssocElems (Tuple ports) (Tuple signals) = 
@@ -302,7 +307,7 @@ mkSignalsFromMap ::
   SignalNameMap 
   -> [AST.SigDec]
 
-mkSignalsFromMap (Signal id ty) =
+mkSignalsFromMap (Single (id, ty)) =
   [mkSignalFromId id ty]
 
 mkSignalsFromMap (Tuple signals) =
@@ -330,29 +335,13 @@ expandArgs binds (e:exprs) = do
 
 expandArgs _ [] = return ([], [], [])
 
--- Is the given name a (binary) tuple constructor
-isTupleConstructor :: Var.Var -> Bool
-isTupleConstructor var =
-  Name.isWiredInName name
-  && Name.nameModule name == tuple_mod
-  && (Name.occNameString $ Name.nameOccName name) == "(,)"
-  where
-    name = Var.varName var
-    mod = nameModule name
-    tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
-
--- Split arguments into type arguments and value arguments This is probably
--- not really sufficient (not sure if Types can actually occur as value
--- arguments...)
-splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
-splitTupleConstructorArgs (e:es) =
-  case e of
-    Type t     -> (e:tys, vals)
-    otherwise  -> (tys, e:vals)
+-- Extract the arguments from a data constructor application (that is, the
+-- normal args, leaving out the type args).
+dataConAppArgs :: DataCon -> [CoreExpr] -> [CoreExpr]
+dataConAppArgs dc args =
+    drop tycount args
   where
-    (tys, vals) = splitTupleConstructorArgs es
-
-splitTupleConstructorArgs [] = ([], [])
+    tycount = length $ DataCon.dataConAllTyVars dc
 
 mapOutputPorts ::
   SignalNameMap      -- The output portnames of the component
@@ -361,7 +350,7 @@ mapOutputPorts ::
 
 -- Map the output port of a component to the output port of the containing
 -- entity.
-mapOutputPorts (Signal portname _) (Signal signalname _) =
+mapOutputPorts (Single (portname, _)) (Single (signalname, _)) =
   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 
 -- Map matching output ports in the tuple
@@ -401,7 +390,7 @@ mkIfaceSigDecs ::
   -> SignalNameMap        -- The ports to generate a map for
   -> [AST.IfaceSigDec]            -- The resulting ports
   
-mkIfaceSigDecs mode (Signal port_id ty) =
+mkIfaceSigDecs mode (Single (port_id, ty)) =
   [AST.IfaceSigDec port_id mode ty]
 
 mkIfaceSigDecs mode (Tuple ports) =
@@ -416,7 +405,7 @@ createSignalAssignments ::
 
 -- A simple assignment of one signal to another (greatly complicated because
 -- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Signal dst _) (Signal src _) =
+createSignalAssignments (Single (dst, _)) (Single (src, _)) =
     [AST.CSSASm assign]
   where
     src_name  = AST.NSimple src
@@ -431,9 +420,14 @@ createSignalAssignments (Tuple dsts) (Tuple srcs) =
 createSignalAssignments dst src =
   error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
 
-data SignalNameMap =
-  Tuple [SignalNameMap]
-  | Signal AST.VHDLId AST.TypeMark   -- A signal (or port) of the given (VDHL) type
+type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
+
+-- | A datatype that maps each of the single values in a haskell structure to
+-- a mapto. The map has the same structure as the haskell type mapped, ie
+-- nested tuples etc.
+data HsValueMap mapto =
+  Tuple [HsValueMap mapto]
+  | Single mapto
   deriving (Show)
 
 -- Generate a port name map (or multiple for tuple types) in the given direction for
@@ -449,7 +443,7 @@ getPortNameMapForTy name ty =
     -- Expand tuples we find
     Tuple (getPortNameMapForTys name 0 args)
   else -- Assume it's a type constructor application, ie simple data type
-    Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
+    Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
   where
     (tycon, args) = Type.splitTyConApp ty 
 
@@ -520,10 +514,10 @@ mkVHDLId = AST.unsafeVHDLBasicId
 
 builtin_funcs = 
   [ 
-    ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
-    ("hwand", HWFunction (mkVHDLId "hwand") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
-    ("hwor", HWFunction (mkVHDLId "hwor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
-    ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal (mkVHDLId "i") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty))
+    ("hwxor", HWFunction (mkVHDLId "hwxor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwand", HWFunction (mkVHDLId "hwand") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwor", HWFunction (mkVHDLId "hwor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwnot", HWFunction (mkVHDLId "hwnot") [Single (mkVHDLId "i", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty)))
   ]
 
 vhdl_bit_ty :: AST.TypeMark