Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
authorChristiaan Baaij <christiaan.baaij@gmail.com>
Fri, 19 Jun 2009 10:17:44 +0000 (12:17 +0200)
committerChristiaan Baaij <christiaan.baaij@gmail.com>
Fri, 19 Jun 2009 10:17:44 +0000 (12:17 +0200)
* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Use highordtest in main, since that can now be normalized.
  Add a (fairly complete) set of transforms.
  Add is_lam and is_fun predicates.
  Add a inlinebind helper function.
  Add a substitute helper function.
  Print the type in the transform debug output.
  Add infrastructure for running core to core transformations.
  Add a higher order testcase.
  Add is_wild function to check for wild binders.
  Generate VHDL from Core instead of flat functions.

Conflicts:
Translator.hs
VHDL.hs

13 files changed:
.gitignore
Alu.hs
Bits.hs
Constants.hs [new file with mode: 0644]
CoreTools.hs
Generate.hs [new file with mode: 0644]
GlobalNameTable.hs [new file with mode: 0644]
LICENSE [new file with mode: 0644]
Main.hs [new file with mode: 0644]
Translator.hs
VHDL.hs
VHDLTypes.hs
cλash.cabal [new file with mode: 0644]

index 31ab9cc4dd2060a378a02f96f595520bdbd4287b..a08978a885f190d9fde54c14d31157af2aaa8e2a 100644 (file)
@@ -1,3 +1,5 @@
 *.hi
 *.o
 *.swp
+dist
+vhdl
diff --git a/Alu.hs b/Alu.hs
index 54039084b7ac6cffbea6c369cfaed4e7ab013fb7..b3d5b220f13970bc123ccafd776dab62ffa483dd 100644 (file)
--- a/Alu.hs
+++ b/Alu.hs
@@ -2,7 +2,7 @@ module Alu  where
 import Bits
 import qualified Sim
 import Data.SizedWord
-import Types.Data.Num
+import Types
 
 main = Sim.simulate exec program initial_state
 mainIO = Sim.simulateIO exec initial_state
diff --git a/Bits.hs b/Bits.hs
index cea48cc0c457f1d3772eb75f3f2276d1957c251f..b50430af9644553c657e6d6bb5ff5f95e1d69ad8 100644 (file)
--- a/Bits.hs
+++ b/Bits.hs
@@ -2,8 +2,8 @@
 
 module Bits where
 
-import qualified Data.Param.FSVec as FSVec
-import qualified Data.TypeLevel as TypeLevel
+import qualified Data.Param.TFVec as TFVec
+import qualified Types
 
 --class Signal a where
 --     hwand :: a -> a -> a
@@ -58,6 +58,6 @@ type Stream a = [a]
 lows  = Low : lows
 highs = High : highs
 
-type BitVec len = FSVec.FSVec len Bit
+type BitVec len = TFVec.TFVec len Bit
 
 -- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/Constants.hs b/Constants.hs
new file mode 100644 (file)
index 0000000..3a0e088
--- /dev/null
@@ -0,0 +1,174 @@
+module Constants where
+  
+import qualified ForSyDe.Backend.VHDL.AST as AST
+
+--------------
+-- Identifiers
+--------------
+
+-- | reset and clock signal identifiers in String form
+resetStr, clockStr :: String
+resetStr = "resetn"
+clockStr = "clock"
+
+-- | reset and clock signal identifiers in basic AST.VHDLId form
+resetId, clockId :: AST.VHDLId
+resetId = AST.unsafeVHDLBasicId resetStr
+clockId = AST.unsafeVHDLBasicId clockStr
+
+
+-- | \"types\" identifier
+typesId :: AST.VHDLId
+typesId = AST.unsafeVHDLBasicId "types"
+
+-- | work identifier
+workId :: AST.VHDLId
+workId = AST.unsafeVHDLBasicId "work"
+
+-- | std identifier
+stdId :: AST.VHDLId
+stdId = AST.unsafeVHDLBasicId "std"
+
+
+-- | textio identifier
+textioId :: AST.VHDLId
+textioId = AST.unsafeVHDLBasicId "textio"
+
+-- | range attribute identifier
+rangeId :: AST.VHDLId
+rangeId = AST.unsafeVHDLBasicId "range"
+
+
+-- | range attribute identifier
+imageId :: AST.VHDLId
+imageId = AST.unsafeVHDLBasicId "image"
+
+-- | event attribute identifie
+eventId :: AST.VHDLId
+eventId = AST.unsafeVHDLBasicId "event"
+
+
+-- | default function identifier
+defaultId :: AST.VHDLId
+defaultId = AST.unsafeVHDLBasicId "default"
+
+-- FSVec function identifiers
+
+-- | ex (operator ! in original Haskell source) function identifier
+exId :: AST.VHDLId
+exId = AST.unsafeVHDLBasicId "ex"
+
+-- | sel (function select in original Haskell source) function identifier
+selId :: AST.VHDLId
+selId = AST.unsafeVHDLBasicId "sel"
+
+
+-- | ltplus (function (<+) in original Haskell source) function identifier
+ltplusId :: AST.VHDLId
+ltplusId = AST.unsafeVHDLBasicId "ltplus"
+
+
+-- | plusplus (function (++) in original Haskell source) function identifier
+plusplusId :: AST.VHDLId
+plusplusId = AST.unsafeVHDLBasicId "plusplus"
+
+
+-- | empty function identifier
+emptyId :: AST.VHDLId
+emptyId = AST.unsafeVHDLBasicId "empty"
+
+-- | plusgt (function (+>) in original Haskell source) function identifier
+plusgtId :: AST.VHDLId
+plusgtId = AST.unsafeVHDLBasicId "plusgt"
+
+-- | singleton function identifier
+singletonId :: AST.VHDLId
+singletonId = AST.unsafeVHDLBasicId "singleton"
+
+-- | length function identifier
+lengthId :: AST.VHDLId
+lengthId = AST.unsafeVHDLBasicId "length"
+
+
+-- | isnull (function null in original Haskell source) function identifier
+isnullId :: AST.VHDLId
+isnullId = AST.unsafeVHDLBasicId "isnull"
+
+
+-- | replace function identifier
+replaceId :: AST.VHDLId
+replaceId = AST.unsafeVHDLBasicId "replace"
+
+
+-- | head function identifier
+headId :: AST.VHDLId
+headId = AST.unsafeVHDLBasicId "head"
+
+
+-- | last function identifier
+lastId :: AST.VHDLId
+lastId = AST.unsafeVHDLBasicId "last"
+
+
+-- | init function identifier
+initId :: AST.VHDLId
+initId = AST.unsafeVHDLBasicId "init"
+
+
+-- | tail function identifier
+tailId :: AST.VHDLId
+tailId = AST.unsafeVHDLBasicId "tail"
+
+
+-- | take function identifier
+takeId :: AST.VHDLId
+takeId = AST.unsafeVHDLBasicId "take"
+
+
+-- | drop function identifier
+dropId :: AST.VHDLId
+dropId = AST.unsafeVHDLBasicId "drop"
+
+-- | shiftl function identifier
+shiftlId :: AST.VHDLId
+shiftlId = AST.unsafeVHDLBasicId "shiftl"
+
+-- | shiftr function identifier
+shiftrId :: AST.VHDLId
+shiftrId = AST.unsafeVHDLBasicId "shiftr"
+
+-- | rotl function identifier
+rotlId :: AST.VHDLId
+rotlId = AST.unsafeVHDLBasicId "rotl"
+
+-- | reverse function identifier
+rotrId :: AST.VHDLId
+rotrId = AST.unsafeVHDLBasicId "rotr"
+
+-- | reverse function identifier
+reverseId :: AST.VHDLId
+reverseId = AST.unsafeVHDLBasicId "reverse"
+
+-- | copy function identifier
+copyId :: AST.VHDLId
+copyId = AST.unsafeVHDLBasicId "copy"
+
+------------------
+-- VHDL type marks
+------------------
+
+-- | Stardard logic type mark
+std_logicTM :: AST.TypeMark
+std_logicTM = AST.unsafeVHDLBasicId "std_logic"
+
+-- | boolean type mark
+booleanTM :: AST.TypeMark
+booleanTM = AST.unsafeVHDLBasicId "boolean"
+
+-- | fsvec_index AST. TypeMark
+tfvec_indexTM :: AST.TypeMark
+tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
+
+-- | natural AST. TypeMark
+naturalTM :: AST.TypeMark
+naturalTM = AST.unsafeVHDLBasicId "natural"
\ No newline at end of file
index 3dfaf5016cedb0ede442564d2e22452d9cc16e37..a8dce3fab43ac345762307704a27b6d1e31592b3 100644 (file)
@@ -61,24 +61,24 @@ sized_word_len ty =
 
 -- | Evaluate a core Type representing type level int from the TypeLevel
 -- library to a real int.
-eval_type_level_int :: Type.Type -> Int
-eval_type_level_int ty =
-  unsafeRunGhc $ do
-    -- Automatically import modules for any fully qualified identifiers
-    setDynFlag DynFlags.Opt_ImplicitImportQualified
-
-    let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
-    let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
-    let undef = hsTypedUndef $ coreToHsType ty
-    let app = HsExpr.HsApp (to_int) (undef)
-
-    core <- toCore [] app
-    execCore core 
+-- eval_type_level_int :: Type.Type -> Int
+-- eval_type_level_int ty =
+--   unsafeRunGhc $ do
+--     -- Automatically import modules for any fully qualified identifiers
+--     setDynFlag DynFlags.Opt_ImplicitImportQualified
+-- 
+--     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
+--     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
+--     let undef = hsTypedUndef $ coreToHsType ty
+--     let app = HsExpr.HsApp (to_int) (undef)
+-- 
+--     core <- toCore [] app
+--     execCore core 
 
 -- | Get the length of a FSVec type
-fsvec_len :: Type.Type -> Int
-fsvec_len ty =
-  eval_type_level_int len
+tfvec_len :: Type.Type -> Int
+tfvec_len ty =
+  eval_tfp_int len
   where 
     (tycon, args) = Type.splitTyConApp ty
     [len, el_ty] = args
diff --git a/Generate.hs b/Generate.hs
new file mode 100644 (file)
index 0000000..97d9488
--- /dev/null
@@ -0,0 +1,157 @@
+module Generate where
+  
+import qualified ForSyDe.Backend.VHDL.AST as AST
+import Constants
+
+-- | Generate a function call from the Function Name and a list of expressions
+--   (its arguments)
+genExprFCall :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall fName args = 
+   AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
+             map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+
+-- | List version of genExprFCall1
+genExprFCall1L :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall1L fName [arg] = genExprFCall fName [arg]
+genExprFCall1L _ _ = error "Generate.genExprFCall1L incorrect length"
+
+-- | List version of genExprFCall2
+genExprFCall2L :: AST.VHDLId -> [AST.Expr] -> AST.Expr
+genExprFCall2L fName [arg1, arg2] = genExprFCall fName [arg1,arg2]
+genExprFCall2L _ _ = error "Generate.genExprFCall2L incorrect length"
+
+genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
+                    -> AST.TypeMark -- ^ type of the vector
+                    -> [AST.SubProgBody]
+genUnconsVectorFuns elemTM vectorTM  = 
+  [ AST.SubProgBody exSpec      []                  [exExpr]                    
+  , AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet]   
+    , AST.SubProgBody headSpec    []                  [headExpr]                  
+    , AST.SubProgBody lastSpec    []                  [lastExpr]                  
+    , AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet]         
+    , AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet]         
+    , AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet]         
+    , AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet]         
+  ]
+  where 
+    ixPar   = AST.unsafeVHDLBasicId "ix"
+    vecPar  = AST.unsafeVHDLBasicId "vec"
+    nPar    = AST.unsafeVHDLBasicId "n"
+    iId     = AST.unsafeVHDLBasicId "i"
+    iPar    = iId
+    aPar    = AST.unsafeVHDLBasicId "a"
+    resId   = AST.unsafeVHDLBasicId "res"
+    exSpec = AST.Function exId [AST.IfaceVarDec vecPar vectorTM,
+                               AST.IfaceVarDec ixPar  naturalTM] elemTM
+    exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
+              (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $ 
+                AST.NSimple ixPar]))
+    replaceSpec = AST.Function replaceId  [ AST.IfaceVarDec vecPar vectorTM
+                                          , AST.IfaceVarDec iPar   naturalTM
+                                          , AST.IfaceVarDec aPar   elemTM
+                                          ] vectorTM 
+       -- variable res : fsvec_x (0 to vec'length-1);
+    replaceVar =
+         AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.IndexConstraint 
+                   [AST.ToRange (AST.PrimLit "0")
+                            (AST.PrimName (AST.NAttribute $ 
+                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                                (AST.PrimLit "1"))   ]))
+                Nothing
+       --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
+    replaceExpr = AST.NSimple resId AST.:=
+           (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
+            AST.PrimName (AST.NSimple aPar) AST.:&: 
+             vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
+                      ((AST.PrimName (AST.NAttribute $ 
+                                AST.AttribName (AST.NSimple vecPar) lengthId Nothing)) 
+                                                              AST.:-: AST.PrimLit "1"))
+    replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    vecSlice init last =  AST.PrimName (AST.NSlice 
+                                        (AST.SliceName 
+                                              (AST.NSimple vecPar) 
+                                              (AST.ToRange init last)))
+    headSpec = AST.Function headId [AST.IfaceVarDec vecPar vectorTM] elemTM
+       -- return vec(0);
+    headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
+                    (AST.NSimple vecPar) [AST.PrimLit "0"])))
+    lastSpec = AST.Function lastId [AST.IfaceVarDec vecPar vectorTM] elemTM
+       -- return vec(vec'length-1);
+    lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
+                    (AST.NSimple vecPar) 
+                    [AST.PrimName (AST.NAttribute $ 
+                                AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                                             AST.:-: AST.PrimLit "1"])))
+    initSpec = AST.Function initId [AST.IfaceVarDec vecPar vectorTM] vectorTM 
+       -- variable res : fsvec_x (0 to vec'length-2);
+    initVar = 
+         AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.IndexConstraint 
+                   [AST.ToRange (AST.PrimLit "0")
+                            (AST.PrimName (AST.NAttribute $ 
+                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                                (AST.PrimLit "2"))   ]))
+                Nothing
+       -- resAST.:= vec(0 to vec'length-2)
+    initExpr = AST.NSimple resId AST.:= (vecSlice 
+                               (AST.PrimLit "0") 
+                               (AST.PrimName (AST.NAttribute $ 
+                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                                             AST.:-: AST.PrimLit "2"))
+    initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    tailSpec = AST.Function tailId [AST.IfaceVarDec vecPar vectorTM] vectorTM
+       -- variable res : fsvec_x (0 to vec'length-2); 
+    tailVar = 
+         AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.IndexConstraint 
+                   [AST.ToRange (AST.PrimLit "0")
+                            (AST.PrimName (AST.NAttribute $ 
+                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                                (AST.PrimLit "2"))   ]))
+                Nothing       
+       -- res AST.:= vec(1 to vec'length-1)
+    tailExpr = AST.NSimple resId AST.:= (vecSlice 
+                               (AST.PrimLit "1") 
+                               (AST.PrimName (AST.NAttribute $ 
+                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                                             AST.:-: AST.PrimLit "1"))
+    tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    takeSpec = AST.Function takeId [AST.IfaceVarDec nPar   naturalTM,
+                                   AST.IfaceVarDec vecPar vectorTM ] vectorTM
+       -- variable res : fsvec_x (0 to n-1);
+    takeVar = 
+         AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.IndexConstraint 
+                   [AST.ToRange (AST.PrimLit "0")
+                               ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+                                (AST.PrimLit "1"))   ]))
+                Nothing
+       -- res AST.:= vec(0 to n-1)
+    takeExpr = AST.NSimple resId AST.:= 
+                    (vecSlice (AST.PrimLit "1") 
+                              (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
+    takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    dropSpec = AST.Function dropId [AST.IfaceVarDec nPar   naturalTM,
+                                   AST.IfaceVarDec vecPar vectorTM ] vectorTM 
+       -- variable res : fsvec_x (0 to vec'length-n-1);
+    dropVar = 
+         AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.IndexConstraint 
+                   [AST.ToRange (AST.PrimLit "0")
+                            (AST.PrimName (AST.NAttribute $ 
+                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                               (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
+               Nothing
+       -- res AST.:= vec(n to vec'length-1)
+    dropExpr = AST.NSimple resId AST.:= (vecSlice 
+                               (AST.PrimName $ AST.NSimple nPar) 
+                               (AST.PrimName (AST.NAttribute $ 
+                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                                             AST.:-: AST.PrimLit "1"))
+    dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
\ No newline at end of file
diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs
new file mode 100644 (file)
index 0000000..ef4b25e
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module GlobalNameTable (globalNameTable) where
+
+import Language.Haskell.TH
+import qualified Data.Map as Map
+
+import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified Data.Param.TFVec as V
+
+import VHDLTypes
+import Constants
+import Generate
+
+mkGlobalNameTable :: [(String, (Int, [AST.Expr] -> AST.Expr ) )] -> NameTable
+mkGlobalNameTable = Map.fromList
+
+globalNameTable :: NameTable
+globalNameTable = mkGlobalNameTable
+  [ (show ('(V.!))           , (2, genExprFCall2L exId                           ) )
+  , ("head"          , (1, genExprFCall1L headId                         ) )
+  ]
\ No newline at end of file
diff --git a/LICENSE b/LICENSE
new file mode 100644 (file)
index 0000000..23ebcfd
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,25 @@
+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+    * Neither the name of the copyright holder nor the
+      names of its contributors may be used to endorse or promote products
+      derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
diff --git a/Main.hs b/Main.hs
new file mode 100644 (file)
index 0000000..be48aa3
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import Translator
+
+main = do
+  makeVHDL "Adders.hs" "highordtest" True
\ No newline at end of file
index 3f60330b37a68b8680cdedec20996f28134c5a42..0f60277671f99b646ec427deb8fd82ce92d53169 100644 (file)
@@ -52,8 +52,8 @@ import FlattenTypes
 import VHDLTypes
 import qualified VHDL
 
-main = do
-  makeVHDL "Adders.hs" "highordtest" True
+-- main = do
+--   makeVHDL "Alu.hs" "exec" True
 
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
@@ -62,7 +62,7 @@ makeVHDL filename name stateful = do
   -- Translate to VHDL
   vhdl <- moduleToVHDL core [(name, stateful)]
   -- Write VHDL to file
-  let dir = "../vhdl/vhdl/" ++ name ++ "/"
+  let dir = "./vhdl/" ++ name ++ "/"
   mapM (writeVHDL dir) vhdl
   return ()
 
diff --git a/VHDL.hs b/VHDL.hs
index 561c2790d5537bc56d4f5b12d6d9505b2f2a30fb..d177a10b934dc8004425a150552de5df83c12e4e 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -38,6 +38,9 @@ import TranslatorTypes
 import HsValueMap
 import Pretty
 import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
 
 createDesignFiles ::
   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
@@ -48,7 +51,7 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLSession Map.empty builtin_funcs
+    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     ty_decls = Map.elems (final_session ^. vsTypes)
@@ -109,7 +112,7 @@ createEntity (fname, expr) = do
       CoreSyn.CoreBndr 
       -> VHDLState VHDLSignalMapElement
     -- We only need the vsTypes element from the state
-    mkMap = MonadState.lift vsTypes . (\bndr ->
+    mkMap = (\bndr ->
       let
         --info = Maybe.fromMaybe
         --  (error $ "Signal not found in the name map? This should not happen!")
@@ -191,7 +194,7 @@ createArchitecture (fname, expr) = do
     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs
     -- mkSigDec only uses vsTypes from the state
-    mkSigDec' = MonadState.lift vsTypes . mkSigDec
+    mkSigDec' = mkSigDec
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
@@ -220,7 +223,7 @@ mkStateProcSm (num, old, new) =
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
-mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 mkSigDec bndr =
   if True then do --isInternalSigUse use || isStateSigUse use then do
     type_mark <- vhdl_ty $ Var.varType bndr
@@ -281,7 +284,7 @@ mkConcSm sigs (UncondDef src dst) _ = do
           -- Create a cast expression, which is just a function call using the
           -- type name as the function name.
           let litexpr = AST.PrimLit lit
-          ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+          ty_id <- vhdl_ty ty
           let ty_name = AST.NSimple ty_id
           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
           return $ AST.PrimFCall $ AST.FCall ty_name args
@@ -361,9 +364,9 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 vhdl_ty ty = do
-  typemap <- State.get
+  typemap <- getA vsTypes
   let builtin_ty = do -- See if this is a tycon and lookup its name
         (tycon, args) <- Type.splitTyConApp_maybe ty
         let name = Name.getOccString (TyCon.tyConName tycon)
@@ -380,7 +383,7 @@ vhdl_ty ty = do
             (tycon, args) <- Type.splitTyConApp_maybe ty
             let name = Name.getOccString (TyCon.tyConName tycon)
             case name of
-              "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+              "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
               "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
               otherwise -> Nothing
       -- Return new_ty when a new type was successfully created
@@ -392,7 +395,7 @@ vhdl_ty ty = do
 mk_vector_ty ::
   Int -- ^ The length of the vector
   -> Type.Type -- ^ The Haskell type to create a VHDL type for
-  -> TypeState AST.TypeMark -- The typemark created.
+  -> VHDLState AST.TypeMark -- The typemark created.
 
 mk_vector_ty len ty = do
   -- Assume there is a single type argument
@@ -402,7 +405,9 @@ mk_vector_ty len ty = do
   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
   let ty_dec = AST.TypeDec ty_id ty_def
   -- TODO: Check name uniqueness
-  State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+  --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+  modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
+  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
   return ty_id
 
 
index 784b09706e6a6742a4fb504640983e8973349225..e517a8ba08166d6c5800bdb5d4f41b3e4ab74876 100644 (file)
@@ -45,15 +45,25 @@ instance Ord OrdType where
 -- A map of a Core type to the corresponding type name
 type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec)
 
+-- A map of a vector Core type to the coressponding VHDL functions
+type TypeFunMap = Map.Map OrdType [AST.SubProgBody]
+
 -- A map of a Haskell function to a hardware signature
 type SignatureMap = Map.Map String Entity
 
+-- A map of a builtin function to VHDL function builder 
+type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr )
+
 data VHDLSession = VHDLSession {
   -- | A map of Core type -> VHDL Type
-  vsTypes_ :: TypeMap,
+  vsTypes_      :: TypeMap,
+  -- | A map of vector Core type -> VHDL type function
+  vsTypeFuns_   :: TypeFunMap,
   -- | A map of HsFunction -> hardware signature (entity name, port names,
   --   etc.)
-  vsSignatures_ :: SignatureMap
+  vsSignatures_ :: SignatureMap,
+  -- | A map of Vector HsFunctions -> VHDL function call
+  vsNameTable_  :: NameTable
 }
 
 -- Derive accessors
diff --git a/cλash.cabal b/cλash.cabal
new file mode 100644 (file)
index 0000000..798b281
--- /dev/null
@@ -0,0 +1,21 @@
+name:                clash
+version:             0.1
+build-type:          Simple
+synopsis:            CAES Languege for Hardware Descriptions (CλasH)
+description:         CλasH is a toolchain/language to translate subsets of Haskell to synthesizable VHDL. It does this by translating the intermediate System Fc (GHC Core) representation to a VHDL AST, which is then written to file.
+category:            Development
+license:             BSD3
+license-file:        LICENSE
+package-url:         http://github.com/darchon/clash/tree/master
+copyright:           Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+author:              Christiaan Baaij & Matthijs Kooijman
+stability:           alpha
+maintainer:          christiaan.baaij@gmail.com & matthijs@stdin.nl
+build-depends:       base > 4, syb, ghc, ghc-paths, transformers, haskell98,
+                     ForSyDe, regex-posix ,data-accessor-template, pretty,
+                     data-accessor, containers, prettyclass, tfp > 0.3, 
+                     tfvec, QuickCheck, template-haskell
+
+executable:          clash
+main-is:             Main.hs     
+ghc-options: