X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=fcfd91171376aff196e9f2514e5dacf1ad927d39;hb=ef589dec9b04aa3d0a30a2b0787c50d07c320563;hp=4f4e75cf122ac758be03066ec40c36f261ffbae1;hpb=3a611c1075c67670ed6c86a5e74b59b0b379721c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 4f4e75c..fcfd911 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -28,9 +28,11 @@ import qualified Name
 import qualified OccName
 import qualified Var
 import qualified Id
+import qualified IdInfo
 import qualified TyCon
 import qualified DataCon
 import qualified CoreSubst
+import qualified CoreUtils
 import Outputable ( showSDoc, ppr )
 
 -- Local imports
@@ -50,14 +52,15 @@ createDesignFiles ::
   -> [(AST.VHDLId, AST.DesignFile)]
 
 createDesignFiles binds =
-  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
     init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
-    ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
+    tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
+    ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
         mkUseAll ["IEEE", "std_logic_1164"],
@@ -66,7 +69,13 @@ createDesignFiles binds =
     full_context =
       mkUseAll ["work", "types"]
       : ieee_context
-    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
+    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs)
+    type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
+    subProgSpecs = concat (map subProgSpec tyfun_decls)
+    subProgSpec = map (\(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
@@ -248,33 +257,60 @@ mkConcSm ::
   -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
-  signatures <- getA vsSignatures
-  funSignatures <- getA vsNameTable
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-  case (Map.lookup (bndrToString f) funSignatures) of
-    Just funSignature ->
-      let
-        sigs = map (bndrToString.varBndr) args
-        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
-        func = (snd funSignature) sigsNames
-        src_wform = AST.Wform [AST.WformElem func Nothing]
-        dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
-        assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-      in
-        return $ AST.CSSASm assign
-    Nothing ->
+  case Var.globalIdVarDetails f of
+    IdInfo.DataConWorkId dc ->
+        -- It's a datacon. Create a record from its arguments.
+        -- First, filter out type args. TODO: Is this the best way to do this?
+        -- The types should already have been taken into acocunt when creating
+        -- the signal, so this should probably work...
+        let valargs = filter isValArg args in
+        if all is_var valargs then do
+          labels <- getFieldLabels (CoreUtils.exprType app)
+          let assigns = zipWith mkassign labels valargs
+          let block_id = bndrToVHDLId bndr
+          let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
+          return $ AST.CSBSm block
+        else
+          error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
+      where
+        mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
+        mkassign label (Var arg) =
+          let sel_name = mkSelectedName bndr label in
+          mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
+    IdInfo.VanillaGlobal -> do
+      -- It's a global value imported from elsewhere. These can be builting
+      -- functions.
+      funSignatures <- getA vsNameTable
+      case (Map.lookup (bndrToString f) funSignatures) of
+        Just funSignature ->
+          let
+            sigs = map (bndrToString.varBndr) args
+            sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+            func = (snd funSignature) sigsNames
+            src_wform = AST.Wform [AST.WformElem func Nothing]
+            dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+            assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+          in
+            return $ AST.CSSASm assign
+        Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
+    IdInfo.NotGlobalId -> do
+      signatures <- getA vsSignatures
+      -- This is a local id, so it should be a function whose definition we
+      -- have and which can be turned into a component instantiation.
       let  
         signature = Maybe.fromMaybe 
           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
           (Map.lookup (bndrToString f) signatures)
         entity_id = ent_id signature
         label = bndrToString bndr
-      -- Add a clk port if we have state
-      --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
-      --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+        -- Add a clk port if we have state
+        --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+        --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
         portmaps = mkAssocElems args bndr signature
-      in
-        return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+        in
+          return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+    details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 
 -- GHC generates some funny "r = r" bindings in let statements before
 -- simplification. This outputs some dummy ConcSM for these, so things will at
@@ -291,16 +327,13 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
         Just i -> do
           labels <- getFieldLabels (Id.idType scrut)
           let label = labels!!i
-          let scrut_name = AST.NSimple $ bndrToVHDLId scrut
-          let sel_suffix = AST.SSimple $ label
-          let sel_name = AST.NSelected $ scrut_name AST.:.: sel_suffix 
+          let sel_name = mkSelectedName scrut label
           let sel_expr = AST.PrimName sel_name
-          return $ mkUncondAssign bndr sel_expr
+          return $ mkUncondAssign (Left bndr) sel_expr
         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
       
     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 
-
 -- Multiple case alt are be conditional assignments and have only wild
 -- binders in the alts and only variables in the case values and a variable
 -- for a scrutinee. We check the constructor of the second alt, since the
@@ -311,35 +344,35 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)]))
     true_expr  = (varToVHDLExpr true)
     false_expr  = (varToVHDLExpr false)
   in
-    return $ mkCondAssign bndr cond_expr true_expr false_expr
+    return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 
 -- Create an unconditional assignment statement
 mkUncondAssign ::
-  CoreBndr -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
   -> AST.Expr -- ^ The expression to assign
   -> AST.ConcSm -- ^ The resulting concurrent statement
-mkUncondAssign bndr expr = mkAssign bndr Nothing expr
+mkUncondAssign dst expr = mkAssign dst Nothing expr
 
 -- Create a conditional assignment statement
 mkCondAssign ::
-  CoreBndr -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
   -> AST.Expr -- ^ The condition
   -> AST.Expr -- ^ The value when true
   -> AST.Expr -- ^ The value when false
   -> AST.ConcSm -- ^ The resulting concurrent statement
-mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false
+mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
 
 -- Create a conditional or unconditional assignment statement
 mkAssign ::
-  CoreBndr -> -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
                                  -- and the value to assign when true.
   AST.Expr -> -- ^ The value to assign when false or no condition
   AST.ConcSm -- ^ The resulting concurrent statement
 
-mkAssign bndr cond false_expr =
+mkAssign dst cond false_expr =
   let
     -- I'm not 100% how this assignment AST works, but this gets us what we
     -- want...
@@ -351,11 +384,23 @@ mkAssign bndr cond false_expr =
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []
     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
-    dst_name  = AST.NSimple (bndrToVHDLId bndr)
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (bndrToVHDLId bndr)
+      Right name -> name
     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
   in
     AST.CSSASm assign
-  
+
+-- Create a record field selector that selects the given label from the record
+-- stored in the given binder.
+mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
+mkSelectedName bndr label =
+  let 
+    sel_prefix = AST.NSimple $ bndrToVHDLId bndr
+    sel_suffix = AST.SSimple $ label
+  in
+    AST.NSelected $ sel_prefix AST.:.: sel_suffix 
+
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
@@ -365,7 +410,7 @@ getFieldLabels ty = do
   -- Get the types map, lookup and unpack the VHDL TypeDef
   types <- getA vsTypes
   case Map.lookup (OrdType ty) types of
-    Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
+    Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 
 -- Turn a variable reference into a AST expression
@@ -512,7 +557,7 @@ vhdl_ty ty = do
         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 
 -- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 construct_vhdl_ty ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
@@ -520,16 +565,19 @@ construct_vhdl_ty ty = do
       case name of
         "TFVec" -> do
           res <- mk_vector_ty (tfvec_len ty) ty
-          return $ Just res
+          return $ Just $ (Arrow.second Left) res
         "SizedWord" -> do
           res <- mk_vector_ty (sized_word_len ty) ty
-          return $ Just res
+          return $ Just $ (Arrow.second Left) res
+        "RangedWord" -> do 
+          res <- mk_natural_ty 0 (ranged_word_bound ty) ty
+          return $ Just $ (Arrow.second Right) res
         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
     Nothing -> return $ Nothing
 
 -- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_tycon_ty tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
@@ -548,7 +596,7 @@ mk_tycon_ty tycon args =
       -- TODO: Special handling for tuples?
       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
       let ty_def = AST.TDR $ AST.RecordTypeDef elems
-      return $ Just (ty_id, ty_def)
+      return $ Just (ty_id, Left ty_def)
     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
   where
     -- Create a subst that instantiates all types passed to the tycon
@@ -572,6 +620,16 @@ mk_vector_ty len ty = do
   modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
   return (ty_id, ty_def)
 
+mk_natural_ty ::
+  Int -- ^ The minimum bound (> 0)
+  -> Int -- ^ The maximum bound (> minimum bound)
+  -> Type.Type -- ^ The Haskell type to create a VHDL type for
+  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+mk_natural_ty min_bound max_bound ty = do
+  let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+  let ty_def = AST.SubtypeIn naturalTM (Nothing)
+  return (ty_id, ty_def)
+
 
 builtin_types = 
   Map.fromList [