Moved to new GHC API (6.11). Also use vhdl package for the VHDL AST
[matthijs/master-project/cλash.git] / Generate.hs
index 4846d58690011e3e3b8d82083feecc67e91c2a19..8dc7a0aaaef50b0dacc7bc0be63df0f0d5a28013 100644 (file)
@@ -14,7 +14,7 @@ import Data.Accessor.MonadState as MonadState
 import Debug.Trace
 
 -- ForSyDe
-import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified Language.VHDL.AST as AST
 
 -- GHC API
 import CoreSyn
@@ -42,17 +42,8 @@ genExprArgs wrap dst func args = do
   args' <- eitherCoreOrExprArgs args
   wrap dst func args'
 
-idM :: a -> VHDLSession a
-idM e = return e
-
-eitherM :: (a -> m c) -> (b -> m c) -> Either a b -> m c
-eitherM f1 f2 e = do
-  case e of
-    Left e1 -> f1 e1
-    Right e2 -> f2 e2
-    
 eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (eitherM (\x -> MonadState.lift vsType $ (varToVHDLExpr (exprToVar x))) idM) args
+eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
 
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be variables.
@@ -134,6 +125,22 @@ genFromSizedWord' (Left res) f args = do
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
+genResize :: BuiltinBuilder
+genResize = genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genResize' (Left res) f [arg] = do {
+  ; let { ty = Var.varType res
+        ; (tycon, args) = Type.splitTyConApp ty
+        ; name = Name.getOccString (TyCon.tyConName tycon)
+        } ;
+  ; len <- case name of
+      "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+      "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+  ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+             [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+  }
+genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
 -- FIXME: I'm calling genLitArgs which is very specific function,
 -- which needs to be fixed as well
 genFromInteger :: BuiltinBuilder
@@ -504,34 +511,8 @@ genApplication ::
   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
   -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
 genApplication dst f args = do
-  case Var.globalIdVarDetails f of
-    IdInfo.DataConWorkId dc -> case dst of
-      -- It's a datacon. Create a record from its arguments.
-      Left bndr -> do
-        -- We have the bndr, so we can get at the type
-        labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
-        args' <- eitherCoreOrExprArgs args
-        return $ zipWith mkassign labels $ args'
-        where
-          mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
-          mkassign label arg =
-            let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
-            mkUncondAssign (Right sel_name) arg
-      Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
-    IdInfo.VanillaGlobal -> do
-      -- It's a global value imported from elsewhere. These can be builtin
-      -- functions. Look up the function name in the name table and execute
-      -- the associated builder if there is any and the argument count matches
-      -- (this should always be the case if it typechecks, but just to be
-      -- sure...).
-      case (Map.lookup (varToString f) globalNameTable) of
-        Just (arg_count, builder) ->
-          if length args == arg_count then
-            builder dst f args
-          else
-            error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-        Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
-    IdInfo.NotGlobalId -> do
+  case Var.isGlobalId f of
+    False -> 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.
@@ -553,18 +534,45 @@ genApplication dst f args = do
           -- unconditional assignment here.
           f' <- MonadState.lift vsType $ varToVHDLExpr f
           return $ [mkUncondAssign dst f']
-            
-    IdInfo.ClassOpId cls -> do
-      -- FIXME: Not looking for what instance this class op is called for
-      -- Is quite stupid of course.
-      case (Map.lookup (varToString f) globalNameTable) of
-        Just (arg_count, builder) ->
-          if length args == arg_count then
-            builder dst f args
-          else
-            error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-        Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
-    details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+    True ->
+      case Var.idDetails f of
+        IdInfo.DataConWorkId dc -> case dst of
+          -- It's a datacon. Create a record from its arguments.
+          Left bndr -> do
+            -- We have the bndr, so we can get at the type
+            labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
+            args' <- eitherCoreOrExprArgs args
+            return $ zipWith mkassign labels $ args'
+            where
+              mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+              mkassign label arg =
+                let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+                mkUncondAssign (Right sel_name) arg
+          Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
+        IdInfo.VanillaId -> do
+          -- It's a global value imported from elsewhere. These can be builtin
+          -- functions. Look up the function name in the name table and execute
+          -- the associated builder if there is any and the argument count matches
+          -- (this should always be the case if it typechecks, but just to be
+          -- sure...).
+          case (Map.lookup (varToString f) globalNameTable) of
+            Just (arg_count, builder) ->
+              if length args == arg_count then
+                builder dst f args
+              else
+                error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+            Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
+        IdInfo.ClassOpId cls -> do
+          -- FIXME: Not looking for what instance this class op is called for
+          -- Is quite stupid of course.
+          case (Map.lookup (varToString f) globalNameTable) of
+            Just (arg_count, builder) ->
+              if length args == arg_count then
+                builder dst f args
+              else
+                error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+            Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
+        details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.
@@ -1026,4 +1034,5 @@ globalNameTable = Map.fromList
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
+  , (resizeId         , (1, genResize               ) )
   ]