From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Thu, 2 Jul 2009 14:44:58 +0000 (+0200)
Subject: We now output VHDL types in the correct order
X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=f5f6d286f56ee1e822ece0258039ba2d2ce920aa

We now output VHDL types in the correct order
---

diff --git a/Adders.hs b/Adders.hs
index 672c83c..6ada7df 100644
--- a/Adders.hs
+++ b/Adders.hs
@@ -174,8 +174,8 @@ highordtest = \x ->
 
 xand a b = hwand a b
 
-functiontest :: TFVec D4 (TFVec D3 Bit) -> TFVec D12 Bit
-functiontest = \v -> let r = concat v in r
+functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit)
+functiontest = \v -> let r = (concat v, head v) in r
 
 xhwnot x = hwnot x
 
diff --git a/HighOrdAlu.hs b/HighOrdAlu.hs
index f7d4516..def7742 100644
--- a/HighOrdAlu.hs
+++ b/HighOrdAlu.hs
@@ -8,9 +8,9 @@ import Types
 import Data.Param.TFVec
 import Data.RangedWord
 
-constant :: NaturalT n => e -> Op n e
+constant :: e -> Op D4 e
 constant e a b =
-  copy e
+  (e +> (e +> (e +> (singleton e))))
 
 invop :: Op n Bit
 invop a b = map hwnot a
@@ -20,12 +20,14 @@ andop a b = zipWith hwand a b
 
 -- Is any bit set?
 --anyset :: (PositiveT n) => Op n Bit
-anyset :: NaturalT n => Op n Bit
+anyset :: (Bit -> Bit -> Bit) -> Op D4 Bit
 --anyset a b = copy undefined (a' `hwor` b')
-anyset a b = constant (a' `hwor` b') a b
+anyset f a b = constant (a' `hwor` b') a b
   where 
-    a' = foldl hwor Low a
-    b' = foldl hwor Low b
+    a' = foldl f Low a
+    b' = foldl f Low b
+
+xhwor = hwor
 
 type Op n e = (TFVec n e -> TFVec n e -> TFVec n e)
 type Opcode = Bit
@@ -38,4 +40,4 @@ alu op1 op2 opc a b =
 
 actual_alu :: Opcode -> TFVec D4 Bit -> TFVec D4 Bit -> TFVec D4 Bit
 --actual_alu = alu (constant Low) andop
-actual_alu = alu anyset andop
+actual_alu = alu (anyset xhwor)  andop
diff --git a/VHDL.hs b/VHDL.hs
index e2eb962..13a9294 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -47,12 +47,11 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLState Map.empty Map.empty Map.empty
+    init_session = VHDLState Map.empty [] Map.empty Map.empty
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
-    ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
-    --vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
+    ty_decls = final_session ^.vsTypeDecls
     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
@@ -69,9 +68,6 @@ createDesignFiles binds =
     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
     subProgSpecs = map subProgSpec tyfun_decls
     subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
-    mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
-    mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
-    mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 
 -- Create a use foo.bar.all statement. Takes a list of components in the used
 -- name. Must contain at least two components
diff --git a/VHDLTools.hs b/VHDLTools.hs
index 5f467b0..3b49b27 100644
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -281,6 +281,7 @@ vhdl_ty msg ty = do
         Just (ty_id, ty_def) -> do
           -- TODO: Check name uniqueness
           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
           return ty_id
         Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 
@@ -362,6 +363,7 @@ mk_vector_ty ty = do
       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
       let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
       modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def)))
+      modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
       let ty_def = AST.SubtypeIn vec_id (Just range)
       return (ty_id, ty_def)
 
@@ -387,3 +389,7 @@ getFieldLabels ty = do
   case Map.lookup (OrdType ty) types of
     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
diff --git a/VHDLTypes.hs b/VHDLTypes.hs
index c1d9332..61fb003 100644
--- a/VHDLTypes.hs
+++ b/VHDLTypes.hs
@@ -51,6 +51,8 @@ type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
 data VHDLState = VHDLState {
   -- | A map of Core type -> VHDL Type
   vsTypes_      :: TypeMap,
+  -- | A list of type declarations
+  vsTypeDecls_  :: [AST.PackageDecItem],
   -- | A map of vector Core type -> VHDL type function
   vsTypeFuns_   :: TypeFunMap,
   -- | A map of HsFunction -> hardware signature (entity name, port names,