We now use compileToCoreSimplified, I'm sure there will be dragons

diff --git a/cλash/CLasH/Utils/Core/CoreTools.hs b/cλash/CLasH/Utils/Core/CoreTools.hs
index a66904e1141334c5d5b66083a24967aed152eea3..7377c9e36ce332e14c04f2a6cde234e47bf8eb95 100644 (file)
--- a/cλash/CLasH/Utils/Core/CoreTools.hs
+++ b/cλash/CLasH/Utils/Core/CoreTools.hs
@@ -220,6 +220,8 @@ getLiterals app@(CoreSyn.App _ _) = literals
     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
     literals = filter (is_lit) args
 
+getLiterals lit@(CoreSyn.Lit _) = [lit]
+
 reduceCoreListToHsList :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
 reduceCoreListToHsList app@(CoreSyn.App _ _) = out
   where

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index 5a041cc021173b79fbcb1ccd3cee14dee6808d8e..5b9bc350e3da973f678c679308b73cc4fd2abeb7 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -89,7 +89,7 @@ loadModules libdir filenames finder =
     GHC.runGhc (Just libdir) $ do
       dflags <- GHC.getSessionDynFlags
       GHC.setSessionDynFlags dflags
-      cores <- mapM GHC.compileToCoreModule filenames
+      cores <- mapM GHC.compileToCoreSimplified filenames
       env <- GHC.getSession
       specs <- case finder of
         Nothing -> return []

diff --git a/cλash/CLasH/VHDL/Constants.hs b/cλash/CLasH/VHDL/Constants.hs
index 04e727410b0e8ed63061fa6c12078ad3823f9038..50bb9222a4681eba55297c44b67968ddf486f232 100644 (file)
--- a/cλash/CLasH/VHDL/Constants.hs
+++ b/cλash/CLasH/VHDL/Constants.hs
@@ -266,6 +266,9 @@ toUnsignedId = "to_unsigned"
 resizeId :: String
 resizeId = "resize"
 
+smallIntegerId :: String
+smallIntegerId = "smallInteger"
+
 sizedIntId :: String
 sizedIntId = "SizedInt"
 

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 5386e7e61b698a0681830ffc9b4b14c2c9c1e67f..f7495408c415f95a04594df71a0ae34729d484b8 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -838,8 +838,30 @@ genApplication dst f args = do
               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))
+                error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+            Nothing -> do
+              top <- isTopLevelBinder f
+              case top of
+                True -> do
+                  -- Local binder that references a top level binding.  Generate a
+                  -- component instantiation.
+                  signature <- getEntity f
+                  args' <- argsToVHDLExprs args
+                  let entity_id = ent_id signature
+                  -- TODO: Using show here isn't really pretty, but we'll need some
+                  -- unique-ish value...
+                  let label = "comp_ins_" ++ (either show prettyShow) dst
+                  portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
+                  return ([mkComponentInst label entity_id portmaps], [f])
+                False -> do
+                  -- Not a top level binder, so this must be a local variable reference.
+                  -- It should have a representable type (and thus, no arguments) and a
+                  -- signal should be generated for it. Just generate an unconditional
+                  -- assignment here.
+                  -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
+                  -- f' <- MonadState.lift tsType $ varToVHDLExpr f
+                  --                   return $ ([mkUncondAssign dst f'], [])
+                  error $ ("\nGenerate.genApplication(VanillaId): 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.
@@ -904,7 +926,7 @@ genUnconsVectorFuns elemTM vectorTM  =
   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
-  , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
+  , (emptyId, (AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr],[]))
   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
@@ -1052,9 +1074,11 @@ genUnconsVectorFuns elemTM vectorTM  =
     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
     emptyVar = 
-          AST.ConstDec resId 
-              (AST.SubtypeIn vectorTM Nothing)
-              (Just $ AST.PrimLit "\"\"")
+          AST.VarDec resId
+            (AST.SubtypeIn vectorTM
+              (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+                [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
+             Nothing
     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ] 
                                          vectorTM
@@ -1329,6 +1353,7 @@ globalNameTable = Map.fromList
   , (fromIntegerId    , (1, genFromInteger          ) )
   , (resizeId         , (1, genResize               ) )
   , (sizedIntId       , (1, genSizedInt             ) )
+  , (smallIntegerId   , (1, genFromInteger          ) )
   --, (tfvecId          , (1, genTFVec                ) )
   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
   ]