diff --git a/HHDL.cabal b/HHDL.cabal new file mode 100644 --- /dev/null +++ b/HHDL.cabal @@ -0,0 +1,82 @@ +-- HHDL.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: HHDL + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1.0.0 + +-- A short (one-line) description of the package. +Synopsis: Hardware Description Language embedded in Haskell. + +-- A longer description of the package. +Description: Hardware Description Language embedded in Haskell. + Main distinction from Lava or similar packages is + that HHDL supports algebraic types with pattern matching. + +-- URL for the project homepage or repository. +Homepage: http://thesz.mskhug.ru/svn/hhdl/hackage/hhdl/ + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Serguey Zefirov + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: sergueyz@gmail.com + +-- Stability is experimental right now. +Stability: experimental + +-- A copyright notice. +Copyright: Copyright (C) 2010, 2011 Serguey Zefirov + +Category: Hardware + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + +-- Tested with. +Tested-with: GHC == 6.12.1 + + +Library + -- Modules exported by the library. + Exposed-modules: Hardware.HHDL + + -- Sources are in proper directory: + hs-source-dirs: src + + -- Packages needed in order to build this package. + Build-depends: base >= 3.0 && < 4.0, + template-haskell >= 2.4 && < 2.5, + containers >= 0.3 && < 0.4, + mtl >= 1.1 + + -- Modules not exported by this package. + Other-modules: Hardware.HHDL.HHDL, Hardware.HHDL.TH, + Hardware.HHDL.BitRepr, Hardware.HHDL.HDLPrelude, + Hardware.HHDL.ToWires, Hardware.HHDL.TyLeA, + Hardware.HHDL.Examples.Clock, Hardware.HHDL.Examples.RunningSum, + Hardware.HHDL.Examples.SimpleSum, + Hardware.HHDL.Examples.RunningSumMaybes + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + + -- Tested with. + -- tested-with: ghc-6.12.1 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Serguey Zefirov + +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 Serguey Zefirov nor the names of other + 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 HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Hardware/HHDL.hs b/src/Hardware/HHDL.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL.hs @@ -0,0 +1,10 @@ +-- |Hardware.HHDL +-- Convenient top-level module that exports everything HHDL-related. + +{-# LANGUAGE NoImplicitPrelude #-} + +module Hardware.HHDL( + module Hardware.HHDL.HHDL + ) where + +import Hardware.HHDL.HHDL diff --git a/src/Hardware/HHDL/BitRepr.hs b/src/Hardware/HHDL/BitRepr.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/BitRepr.hs @@ -0,0 +1,86 @@ +-- |BitRepr.hs +-- Bit representation. + +{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances #-} + +module Hardware.HHDL.BitRepr where + +import Data.Bits + +import Hardware.HHDL.TyLeA + +------------------------------------------------------------------------------- +-- Main class. + +class Nat (BitVectorSize a) => BitRepr a where + type BitVectorSize a + + -- |Convert value to an integer. + toBitVector :: a -> Integer + + -- |Convert integer to value. Conversion should ignore any bits above + -- "bitVectorSize result". + fromBitVector :: Integer -> a + + -- |Size of value in bits. + bitVectorSize :: a -> Int + bitVectorSize a = i + where + getSize :: a -> BitVectorSize a + getSize a = undefined + i = fromNat (getSize a) + + -- |Mask for value's significant bits. + -- In usual bit vectors they are all significant (default variant below). + -- In algebraic types they aren't: data T = B Bool | W Word64. + -- The mask for B x could ignore significant bits from Word64 in W. + -- Right now it is not widely used, so it is safe to leave it as it is. + bitMask :: a -> Integer + bitMask a = shiftL 1 (bitVectorSize a) - 1 + + +------------------------------------------------------------------------------- +-- Support definitions and type functions for algebraic types. +-- instances are generated by calling generateMakeMatches from TH.hs. + +-- |How much bits do we need to pass arguments for any constructor? +type family ArgsBusSize a + +-- |How much bits do we need for constructor selector? +type family SelectorBusSize a + + +-- Utility conversion function. +-- USed for toBitVector/fromBitVector implementations. +_toArgsBusSize :: a -> ArgsBusSize a +_toArgsBusSize = undefined + +_toArgsBusSizeInt :: Nat (ArgsBusSize a) => a -> Int +_toArgsBusSizeInt = fromNat . _toArgsBusSize + +_toSelBusSize :: a -> SelectorBusSize a +_toSelBusSize = undefined + +_toSelBusSizeInt :: Nat (SelectorBusSize a) => a -> Int +_toSelBusSizeInt = fromNat . _toSelBusSize + +_combineConstructorIndexArgs :: Integer -> Int -> Integer -> Integer +_combineConstructorIndexArgs argsVector shift ci = shiftL ci shift .|. argsVector + +-- |Helper class that breaks some type checking dependencies and +-- allow for faster compilation. +class (Nat (ArgsBusSize a), Nat (SelectorBusSize a)) => AlgTypeBitEnc a where + algTypeArgsBusSize :: a -> Int + algTypeArgsBusSize a = fromNat (_toArgsBusSize a) + + algTypeArgsBusMask :: a -> Integer + algTypeArgsBusMask a = shiftL 1 (algTypeArgsBusSize a) - 1 + + algTypeSelectorBusSize :: a -> Int + algTypeSelectorBusSize = _toSelBusSizeInt + + algTypeSelectorBusMask :: a -> Integer + algTypeSelectorBusMask a = shiftL 1 (_toSelBusSizeInt a) - 1 + diff --git a/src/Hardware/HHDL/Examples/Clock.hs b/src/Hardware/HHDL/Examples/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/Examples/Clock.hs @@ -0,0 +1,22 @@ +-- |Hardware.HHDL.Examples.Clock +-- Clock description for examples. + +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-} +{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Hardware.HHDL.Examples.Clock where + +import Hardware.HHDL + +data Clk = Clk deriving Typeable +data Reset = Reset deriving Typeable +instance Clock Clk where + type ClkReset Clk = Reset + clockValue = Clk + clockResetPositive _ = False + clockFrontEdge _ = True + +fixClockedClock :: Clocked (Clk :. Nil) ins outs -> Clocked (Clk :. Nil) ins outs +fixClockedClock clocked = clocked diff --git a/src/Hardware/HHDL/Examples/RunningSum.hs b/src/Hardware/HHDL/Examples/RunningSum.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/Examples/RunningSum.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-} +{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hardware.HHDL.Examples.RunningSum where + +import Data.Word + +import Hardware.HHDL + +import Hardware.HHDL.Examples.Clock +import Hardware.HHDL.Examples.SimpleSum + +------------------------------------------------------------------------------- +-- Running polymorphic sum, ie, accumulator. +-- Demonstrates registers. + +runningSumRec :: (Show a, ArithResult a ~ a, ClockAllowed c clks, IntegerConstant a, BitRepr a, BitRepr (ArithResult a), Arith (Wire c a)) => Clocked clks (Wire c a :. Nil) (Wire c a :. Nil) +runningSumRec = mkClocked "runningSum" $ \(a :. Nil) -> do + rec + sum <- register 0 nextSum + (nextSum :. Nil) <- instantiate simpleSum (a :. sum :. Nil) + return $ sum :. Nil + +runningSumRecVHDLText = writeHDLText VHDL (runningSumRec :: Clocked (Clk :. Nil) (Wire Clk Word8 :. Nil) (Wire Clk Word8 :. Nil)) + (\s -> putStrLn s >> writeFile "runningSum.vhdl" s) + +test = runningSumRecVHDLText diff --git a/src/Hardware/HHDL/Examples/RunningSumMaybes.hs b/src/Hardware/HHDL/Examples/RunningSumMaybes.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/Examples/RunningSumMaybes.hs @@ -0,0 +1,60 @@ +-- Many extensions. I overload many things from Haskell Prelude in the style +-- of Awesome Prelude. Also you may need a Template Haskell transformations +-- on declarations, which derives classes and type families instances, etc, etc. +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-} +{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hardware.HHDL.Examples.RunningSumMaybes where + +import Data.Word + +-- The main module of the library. It exports everything I deemed useful +-- for hardware description - code generation over ADT, netlist operators, some +-- handy functions from Prelude... +-- Also, it contains making of wires for Either and Maybe and matching functions. +import Hardware.HHDL + +-- The description of clocking frequency for our example. +import Hardware.HHDL.Examples.Clock + +------------------------------------------------------------------------------- +-- How to pattern match an algebraic type. + +-- Clocked is a type of entity. It has three arguments: a list of clocking frequencies allowed +-- in netlist, types of inputs and outputs. +runningSumMaybes :: Clock c => Mealy c (Wire c (Maybe Word8) :. Nil) (Wire c Word8 :. Nil) +runningSumMaybes = mkMealyNamed + -- names of inputs and outputs. + (Just ("maybeA" :. Nil, "currentSum" :. Nil)) + -- default value for state. + (0 :. Nil) + "runningSumMaybes" $ \(sum :. Nil) (mbA :. Nil) -> do + -- here we pattern match in the "First class patterns" style. + -- the idea is that for each constructor Cons of algebraic type T we automatically + -- create two functions: + -- - mkCons which creates a wire (of type Wire c T) from wires of arguments and + -- - pCons which matches a wire of type Wire c T with patterns of types of Cons + -- arguments. + -- pJust and pNothing were generated in Hardware.HHDL.HHDL from the description of + -- Maybe type. + -- pvar is a pattern that matches anything and passes that anything as an argument + -- to processing function. + a <- match mbA [ + -- if we have Just x, return it! + pJust pvar --> \(x :. Nil) -> return x + -- default with 0, if Nothing. + , pNothing --> \Nil -> return (constant 0) + ] + -- compute the sum. + nextSum <- assignWire (sum + a) + -- return currently locked sum. + return (nextSum :. Nil, sum :. Nil) + +-- How to obtain VHDL text - we fix polymorphic parameters in Clocked, generate text (with any +-- entities we have to use) and pass it to display and write function. +runningSumMaybesVHDLText = writeHDLText VHDL (runningSumMaybes :: Mealy Clk (Wire Clk (Maybe Word8) :. Nil) (Wire Clk Word8 :. Nil)) + (\s -> putStrLn s >> writeFile "runningSumMaybes.vhdl" s) + +-- a shortcut. +test = runningSumMaybesVHDLText diff --git a/src/Hardware/HHDL/Examples/SimpleSum.hs b/src/Hardware/HHDL/Examples/SimpleSum.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/Examples/SimpleSum.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts, DoRec #-} +{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hardware.HHDL.Examples.SimpleSum where + +import Data.Word + +import Hardware.HHDL + +------------------------------------------------------------------------------- +-- Polymorphic sum of inputs. + +simpleSum :: (Show a, BitRepr a, BitRepr (ArithResult a), Arith (Wire c a)) => Comb (Wire c a :. Wire c a :. Nil) (Wire c (ArithResult a) :. Nil) +simpleSum = mkComb "simpleSum" $ \(a :. b :. Nil) -> do + t <- assignWire (a+b) + return $ t :. Nil + diff --git a/src/Hardware/HHDL/HDLPrelude.hs b/src/Hardware/HHDL/HDLPrelude.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/HDLPrelude.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, NoImplicitPrelude #-} + + +module Hardware.HHDL.HDLPrelude where + +import Prelude + ( putStrLn, ($), (.), IO, (++), String, repeat, zipWith, head + , fst, snd, length, map, Show(..), reverse, Int, Integer, flip, filter + , unwords, unlines, replicate, const, undefined, error, Ordering(..) + , concat, concatMap, tail, iterate, Bool, Char, id) + +import qualified Prelude +import Data.Word + +------------------------------------------------------------------------------- +-- Replacement for Prelude classes. + +infixl 6 +, - +infixl 7 * +class Arith op where + type ArithResult op + (+), (-), (*) :: op -> op -> ArithResult op + +class IntegerConstant a where + fromInteger :: Integer -> a + +class ToInteger a where + toInteger :: a -> Integer + +convertThroughInteger :: (IntegerConstant res, ToInteger arg) => arg -> res +convertThroughInteger = fromInteger . toInteger + +infix 4 ==, /= +class Eq a where + type EqResult a + (==), (/=) :: a -> a -> EqResult a + +infixr 3 && +infixr 2 || +class Boolean b where + not :: b -> b + (&&), (||) :: b -> b -> b + +infix 4 <, >, <=, >= +class Boolean b => Compare a b where + (>), (<), (>=), (<=) :: a -> a -> b + + +------------------------------------------------------------------------------- +-- Required instances. + +instance IntegerConstant Int where + fromInteger = Prelude.fromInteger + +instance ToInteger Int where + toInteger = Prelude.toInteger + +instance IntegerConstant Integer where + fromInteger = Prelude.fromInteger + +instance ToInteger Integer where + toInteger = Prelude.toInteger + +instance Boolean Bool where + not = Prelude.not + (&&) = (Prelude.&&) + (||) = (Prelude.||) + +instance Arith Int where + type ArithResult Int = Int + (+) = (Prelude.+) + (-) = (Prelude.-) + (*) = (Prelude.*) + +instance Arith Integer where + type ArithResult Integer = Integer + (+) = (Prelude.+) + (-) = (Prelude.-) + (*) = (Prelude.*) + +instance Eq Char where + type EqResult Char = Bool + (==) = (Prelude.==) + (/=) = (Prelude./=) + +instance Eq Int where + type EqResult Int = Bool + (==) = (Prelude.==) + (/=) = (Prelude./=) + +instance Compare Int Bool where + (>) = (Prelude.>) + (<) = (Prelude.<) + (>=) = (Prelude.>=) + (<=) = (Prelude.<=) + +instance Arith Word8 where + type ArithResult Word8 = Word8 + (+) = (Prelude.+) + (-) = (Prelude.-) + (*) = (Prelude.*) + +instance Eq Word8 where + type EqResult Word8 = Bool + (==) = (Prelude.==) + (/=) = (Prelude./=) + +instance Eq Integer where + type EqResult Integer = Bool + (==) = (Prelude.==) + (/=) = (Prelude./=) + +instance IntegerConstant Word8 where + fromInteger = Prelude.fromInteger + +instance ToInteger Word8 where + toInteger = Prelude.toInteger diff --git a/src/Hardware/HHDL/HHDL.hs b/src/Hardware/HHDL/HHDL.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/HHDL.hs @@ -0,0 +1,1211 @@ +{-# LANGUAGE RankNTypes, GADTs, TypeFamilies, TypeOperators, TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances, NoImplicitPrelude #-} +{-# LANGUAGE DoRec #-} +-- {-# LANGUAGE NoMonomorphismRestriction #-} + +module Hardware.HHDL.HHDL( + -- convenience exports. + module Data.Typeable + , module Hardware.HHDL.HDLPrelude + , module Prelude + , module Control.Monad.Fix + , module Hardware.HHDL.BitRepr + , module Hardware.HHDL.TyLeA + , module Hardware.HHDL.TH + -- This module exports. + , (:.)(..), Nil(Nil) -- our own HList. + , Wire -- abstract type. + , HDL(..) -- what kind of HDL you want to generate. + , WireOp(..) -- the means to extend operations. + , toBits -- a method to get bit vector from a type. + , WList + , WiresList -- a class that defines list of wires. + , NLM + , Clock(..), ClockAllowed + , Clocked -- the type constructor of clocked circuits. + , mkClockedNamed -- for top-level exported entities. + , mkClocked + , Comb -- the type constrictor of combinational (stateless) circuits. + , mkComb + , Mealy -- simple MEaly state machine. + , mkMealyNamed -- for top-level exported entities. + , mkMealy + , assignWire -- w <- assignWire (expression) + , assignFlattened + , register -- latched <- register defaultValue wireToLatch + , instantiate -- instantiate entity, literally. outputs <- instantiate entity inputs + , constant -- convert Haskell value (BitRepr one) into wire. + , writeHDLText -- write HDL text of an entity. + , match -- match expression against list of patterns. + , (-->) -- combine pattern and netlists. + , pvar, pcst, pwild -- variable match, constant match, wildcard match. + , pJust, mkJust, pNothing, mkNothing -- generated for Maybe. + , pLeft, mkLeft, pRight, mkRight -- generated for Maybe. + ) where + +-- what we need from Prelude: +import Prelude + ( putStrLn, ($), (.), IO, (++), String, repeat, zipWith, head + , fst, snd, length, map, Show(..), reverse, Int, Integer, flip, filter + , unwords, unlines, replicate, const, undefined, error, Ordering(..) + , concat, concatMap, take, tail, iterate, Bool(..), Monad(..) + , writeFile, otherwise, asTypeOf + , foldr, foldl, foldl1, zipWith3, zip, init, Maybe(..), Either(..)) + +import qualified Prelude + +import Control.Monad.State +import Control.Monad +import Control.Monad.Fix +import qualified Data.Bits as B +import qualified Data.Bits +import Data.IORef +import Data.List (nub, intersperse) +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Typeable +import Data.Word +import qualified Language.Haskell.TH as TH +import System.IO.Unsafe +import qualified Text.Printf + +import Hardware.HHDL.BitRepr +import Hardware.HHDL.HDLPrelude +import Hardware.HHDL.TH +import Hardware.HHDL.TyLeA + +------------------------------------------------------------------------------- +-- Our own HList. + +infixr 5 :. + +data a :. as = a :. as deriving Show +data Nil = Nil + +------------------------------------------------------------------------------- +-- Unique index generation. + +{-# NOINLINE uniqueCounterRef #-} +uniqueCounterRef :: IORef Int +uniqueCounterRef = unsafePerformIO (newIORef 0) + +createUniqueIndex :: (String -> Int -> a) -> String -> a +createUniqueIndex mk n = unsafePerformIO $ do + atomicModifyIORef uniqueCounterRef (\x -> (x+1,())) + i <- readIORef uniqueCounterRef + return $ mk n i + +------------------------------------------------------------------------------- +-- What is wire. + +data Wire clk ty where + Wire :: Maybe String -> Int -> Wire clk ty + Expr :: WireOp (op c ty) => op c ty -> Wire c ty + +instance Show (Wire c ty) where + show w = error "No show for wires right now!" + +data HDL = VHDL | Verilog + deriving (Prelude.Eq, Prelude.Ord, Show) + +class BitRepr (WireOpType op) => WireOp op where + type WireOpType op + -- |Transformation to HDL. + opToHDL :: BitRepr (WireOpType op) => HDL -> op -> String + + -- |Flattening transformation. + opFlatten :: op -> NLM clocks op + + opType :: op -> WireOpType op + opType op = undefined + + opTypeSize :: op -> Int + opTypeSize op = bitVectorSize (opType op) + +data SimpleOps c ty where + OpConst :: (BitRepr ty, Show ty) => ty -> SimpleOps c ty + OpSimpleBin :: (BitRepr res, BitRepr arg) => + Wire c arg -> [(HDL,String)] -> Wire c arg -> SimpleOps c res + OpSimpleUn :: (BitRepr res, BitRepr arg) => [(HDL,String)] -> Wire c arg -> SimpleOps c res + +instance BitRepr ty => WireOp (Wire c ty) where + type WireOpType (Wire c ty) = ty + opToHDL hdl wire = case wire of + Wire _ _ -> signalName wire + Expr e -> opToHDL hdl e + opFlatten w@(Wire _ _) = return w + opFlatten (Expr e) = liftM Expr $ opFlatten e + +toBits :: BitRepr ty => ty -> String +toBits x + | n > 1 = show bits + | otherwise = show $ head bits + where + i = toBitVector x + n = bitVectorSize x + bits = reverse $ concatMap show $ take n $ map snd $ tail $ + iterate ((`Prelude.divMod` 2) . fst) (i,0) + +instance BitRepr ty => WireOp (SimpleOps c ty) where + type WireOpType (SimpleOps c ty) = ty + opToHDL hdl (OpConst x) = toBits x + opToHDL hdl (OpSimpleBin l ops r) = opToHDL hdl l++hdlOp++opToHDL hdl r + where + hdlOp = (" "++) $ (++" ") $ + maybe (error $ "No op for hdl "++show hdl) Prelude.id $ + Prelude.lookup hdl ops + opFlatten o@(OpConst x) = return o + opFlatten (OpSimpleBin l ops r) = do + l <- assignFlattened l + r <- assignFlattened r + return $ OpSimpleBin l ops r + +instance (Show ty, BitRepr ty, IntegerConstant ty) => IntegerConstant (Wire c ty) where + fromInteger i = Expr (OpConst (fromInteger i)) + +simpleBinAnyHDL a op b = OpSimpleBin a (Prelude.zip [VHDL, Verilog] (repeat op)) b + +instance (BitRepr ty, Arith ty, BitRepr (ArithResult ty)) => Arith (Wire c ty) where + type ArithResult (Wire c ty) = Wire c (ArithResult ty) + a + b = Expr $ simpleBinAnyHDL a "+" b + a - b = Expr $ simpleBinAnyHDL a "-" b + a * b = Expr $ simpleBinAnyHDL a "*" b + +instance Boolean (Wire c Bool) where + not x = Expr $ OpSimpleUn [(VHDL, "not"), (Verilog, "!")] x + a && b = Expr $ OpSimpleBin a [(VHDL, "and"),(Verilog, "&&")] b + a || b = Expr $ OpSimpleBin a [(VHDL, "or"),(Verilog, "||")] b + + +type family WList c ts +type instance WList c Nil = Nil +type instance WList c (t :. ts) = Wire c t :. WList c ts + +class WiresList a where + type WireNamesList a + mkWireList :: Maybe (WireNamesList a) -> NLM clocks a + copyWireList :: Maybe (WireNamesList a) -> a -> NLM clocks a +instance WiresList Nil where + type WireNamesList Nil = Nil + mkWireList _ = return Nil + copyWireList _ _ = return Nil +instance (BitRepr a, WiresList as) => WiresList (Wire c a :. as) where + type WireNamesList (Wire c a :. as) = String :. WireNamesList as + mkWireList names = do + let (n,ns) = case names of + Just (n :. ns) -> (Just n, Just ns) + Nothing -> (Nothing, Nothing) + a <- mkWire n + as <- mkWireList ns + return (a :. as) + copyWireList names ~(w :. ws) = do + let (n,ns) = case names of + Just (n :. ns) -> (Just n, Just ns) + Nothing -> (Nothing, Nothing) + w <- assignWithForcedCopy n w + ws <- copyWireList ns ws + return (w :. ws) + +class RegisterWiresList a clocks where + type RegisterDefault a + registerWiresList :: RegisterDefault a -> a -> NLM clocks a +instance RegisterWiresList Nil clocks where + type RegisterDefault Nil = Nil + registerWiresList _ _ = return Nil +instance (Show a, BitRepr a, ClockAllowed c clocks, RegisterWiresList as clocks) => RegisterWiresList (Wire c a :. as) clocks where + type RegisterDefault (Wire c a :. as) = a :. RegisterDefault as + registerWiresList ~(a :. as) ~(w :. ws) = do + w' <- register a w + ws' <- registerWiresList as ws + return $ w' :. ws' + +data SignalKind = BitSignal | BusSignal Int deriving Show + +class HDLSignal a where + signalNameKind :: a -> (String, SignalKind) + +signalName :: HDLSignal a => a -> String +signalName = fst . signalNameKind + +signalKind :: HDLSignal a => a -> SignalKind +signalKind = snd . signalNameKind + +wireBusSize :: BitRepr a => Wire c a -> Int +wireBusSize wire = bitVectorSize (wireType wire) + where + wireType :: BitRepr a => Wire c a -> a + wireType _ = undefined + +wireOpBusSize :: (BitRepr (WireOpType op), WireOp op) => op -> Int +wireOpBusSize op = bitVectorSize (projectType op) + where + projectType :: WireOp op => op -> WireOpType op + projectType = undefined + +instance BitRepr a => HDLSignal (Wire c a) where + signalNameKind wire = (name,kind) + where + kind = if width == 1 then BitSignal else BusSignal width + width = wireBusSize wire + name = case wire of + Wire Nothing i -> "generated_temporary_name_"++show i + Wire (Just n) i -> concat [n,"_",show i] + + +class HDLSignals a where + signalsWires :: a -> [(String,SignalKind)] +instance HDLSignals Nil where + signalsWires Nil = [] +instance (HDLSignal a, HDLSignals as) => HDLSignals (a :. as) where + signalsWires (w :. ws) = signalNameKind w : signalsWires ws + +class HDLOp op where + opArgs :: WiresList as => op clk ty -> as + opSize :: BitRepr ty => op clk ty -> Int + +class (Typeable c, Typeable (ClkReset c)) => Clock c where + type ClkReset c + -- |Provide construction of clock value to carry around. + clockValue :: c + -- |Reset sensitivity. + clockResetPositive :: c -> Bool + -- |Front sensitivity. + clockFrontEdge :: c -> Bool + +changeDotsToUnderscores :: Typeable t => t -> String +changeDotsToUnderscores = map (\c -> if c == '.' then '_' else c) . show . typeOf + +clockName :: Clock c => c -> String +clockName c = changeDotsToUnderscores c + +clockResetName :: Clock c => c -> String +clockResetName c = changeDotsToUnderscores $ clockReset c + where + clockReset :: Clock c => c -> ClkReset c + clockReset _ = undefined + +class ClockList l where + clockListValue :: l + clockListClocks :: l -> [String] + clockListResets :: l -> [String] +instance ClockList Nil where + clockListValue = Nil + clockListClocks = const [] + clockListResets = const [] +instance (ClockList t, Clock h) => ClockList (h :. t) where + clockListValue = clockValue :. clockListValue + clockListClocks (c :. cs) = nub $ clockName c : clockListClocks cs + clockListResets (c :. cs) = nub $ clockResetName c : clockListResets cs + +class (Clock c, ClockList cs) => ClockAllowed c cs +instance (Clock c, Clock c1, ClockAllowed c cs) => ClockAllowed c (c1 :. cs) +instance (Clock c, ClockList (c :. cs)) => ClockAllowed c (c :. cs) + +class (ClockList clockSubset, ClockList clockSet) => ClockSubset clockSubset clockSet +instance ClockList clockSet => ClockSubset Nil clockSet +instance (Clock c, ClockAllowed c clockSet, ClockSubset css clockSet, ClockList clockSet) => ClockSubset (c :. css) clockSet + +wireClock :: Clock c => Wire c a -> c +wireClock w = clockValue + +-- |Basic netlist operations. +data NetlistOp domain where + -- Latching wires. First comes default + Register :: (ClockAllowed c clocks, BitRepr a, Show a) => + a -> Wire c a -> Wire c a -> NetlistOp clocks + + + -- Assign dest what + -- dest <= what; + Assign :: BitRepr ty => Wire c ty -> Wire c ty -> NetlistOp clocks + + -- Instance ent + -- entity ent port map (...); + Instance :: (Instantiable entity, HDLSignals ins, HDLSignals outs + , EntityIns entity ~ ins, EntityOuts entity ~ outs) => + entity -> ins -> outs -> NetlistOp clocks + +-- |Netlist type. +data Netlist clocks = Netlist { netlistOperations :: [NetlistOp clocks] } + +-- |State of netlist construction monad. +data NLMS domain = NLMS { + nlmsNetlist :: Netlist domain + , nlmsCounter :: Int + } +emptyNLMS :: NLMS clocked +emptyNLMS = NLMS (Netlist []) 0 + +type NLM clocked a = State (NLMS clocked) a + +mkWire :: BitRepr a => Maybe String -> NLM clocked (Wire c a) +mkWire name = do + n <- liftM nlmsCounter get + modify $ \nlms -> nlms { nlmsCounter = n+1 } + return $ Wire name n + +tempWire :: BitRepr a => NLM clocked (Wire c a) +tempWire = mkWire Nothing + +constant :: (BitRepr a, Show a) => a -> Wire c a +constant c = Expr $ OpConst c + +class (ClockList (EntityClocks entity) + , HDLSignals (EntityIns entity) + , HDLSignals (EntityOuts entity) + , GenHDL entity) => Instantiable entity where + type EntityClocks entity + type EntityIns entity + type EntityOuts entity + getInputsOuputsClocks :: entity + -> (EntityIns entity, EntityOuts entity, EntityClocks entity) + +data Comb ins outs where + Comb :: (HDLSignals ins, HDLSignals outs) => + String -> Int -> ins -> outs -> Netlist Nil -> Comb ins outs + +instance (HDLSignals ins + , HDLSignals outs + , GenHDL (Comb ins outs)) => Instantiable (Comb ins outs) where + type EntityClocks (Comb ins outs) = Nil + type EntityIns (Comb ins outs) = ins + type EntityOuts (Comb ins outs) = outs + getInputsOuputsClocks (Comb _ _ ins outs _) = (ins, outs, Nil) + +runNetlistCreation :: (WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs) + => Maybe (WireNamesList ins, WireNamesList outs) + -> (ins -> outs -> Netlist domain -> a) -> (ins -> NLM domain outs) -> a +runNetlistCreation names q f = mk $ do + ins <- mkWireList (fmap fst names) + outs <- f ins + outs <- copyWireList (fmap snd names) outs + return (ins,outs) + where + mk act = (\((ins,outs),nlms) -> q ins outs (nlmsNetlist nlms)) $ + runState act emptyNLMS + +-- |Create a combinational circut with named inputs and outputs from netlist description. +mkCombNamed :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs) + => Maybe (WireNamesList ins, WireNamesList outs) -> String -> (ins -> NLM Nil outs) -> Comb ins outs +mkCombNamed names n f = runNetlistCreation names (createUniqueIndex Comb n) f + +-- |Create a combinational circut anonymous inputs and outputs from netlist description. +mkComb :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs) + => String -> (ins -> NLM Nil outs) -> Comb ins outs +mkComb n f = mkCombNamed Nothing n f + +-- |Create a combinational circuit from pure function. +-- You can easily shoot your foot here by creating cyclic expressions like +-- 'f a = y where { x = a+y; y = x-a}. +-- Use with care. +mkCombPure :: (HDLSignals ins, HDLSignals outs, WiresList ins, WiresList outs) => String -> (ins -> outs) -> Comb ins outs +mkCombPure n f = mkComb n (\ins -> return (f ins)) + +data Clocked clks ins outs where + Clocked :: (HDLSignals ins, HDLSignals outs, ClockList clks) => + clks -> String -> Int -> ins -> outs -> Netlist clks -> Clocked clks ins outs + +instance (ClockList clks + , HDLSignals ins + , HDLSignals outs + , GenHDL (Clocked clks ins outs)) => Instantiable (Clocked clks ins outs) where + type EntityClocks (Clocked clks ins outs) = clks + type EntityIns (Clocked clks ins outs) = ins + type EntityOuts (Clocked clks ins outs) = outs + getInputsOuputsClocks (Clocked clks _ _ ins outs _) = (ins, outs, clks) + +mkClockedNamed :: (ClockList clks, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs) + => Maybe (WireNamesList ins, WireNamesList outs) -> String + -> (ins -> NLM clks outs) -> Clocked clks ins outs +mkClockedNamed names n f = runNetlistCreation names (createUniqueIndex (Clocked clockListValue) n) f + +mkClocked :: (ClockList clks, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs) + => String -> (ins -> NLM clks outs) -> Clocked clks ins outs +mkClocked n f = mkClockedNamed Nothing n f + +data Mealy clk ins outs where + Mealy :: (HDLSignals ins, HDLSignals outs, Clock clk) => + clk -> String -> Int -> ins -> outs -> Netlist (clk :. Nil) -> Mealy clk ins outs + +instance (Clock clk + , HDLSignals ins + , HDLSignals outs + , GenHDL (Mealy clk ins outs)) => Instantiable (Mealy clk ins outs) where + type EntityClocks (Mealy clk ins outs) = clk :. Nil + type EntityIns (Mealy clk ins outs) = ins + type EntityOuts (Mealy clk ins outs) = outs + getInputsOuputsClocks (Mealy clk _ _ ins outs _) = (ins, outs, clk :. Nil) + +mkMealyNamed :: (Clock clk, WiresList state, HDLSignals state, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs, RegisterWiresList state (clk :. Nil)) + => Maybe (WireNamesList ins, WireNamesList outs) + -> RegisterDefault state -> String -> (state -> ins -> NLM (clk :. Nil) (state, outs)) + -> Mealy clk ins outs +mkMealyNamed names defs n f = runNetlistCreation names (createUniqueIndex (Mealy clockValue) n) action + where + action ins = do + rec + state <- registerWiresList defs nextState + ~(nextState, outs) <- f state ins + return outs +mkMealy:: (Clock clk, WiresList state, HDLSignals state, WiresList ins, WiresList outs, HDLSignals ins, HDLSignals outs, RegisterWiresList state (clk :. Nil)) + => RegisterDefault state -> String -> (state -> ins -> NLM (clk :. Nil) (state, outs)) + -> Mealy clk ins outs +mkMealy defs n f = mkMealyNamed Nothing defs n f + +------------------------------------------------------------------------------- +-- BitRepr instances. + +instance BitRepr Int where + type BitVectorSize Int = $(tySize 32) + toBitVector x = convertThroughInteger x + fromBitVector x = convertThroughInteger x + bitVectorSize x = 32 + +instance BitRepr Word8 where + type BitVectorSize Word8 = $(tySize 8) + toBitVector x = convertThroughInteger x + fromBitVector x = convertThroughInteger x + bitVectorSize x = 8 + +instance BitRepr Nil where + type BitVectorSize Nil = $(tySize 0) + toBitVector x = 0 + fromBitVector x = Nil + bitVectorSize x = 0 + +instance (BitRepr a, BitRepr as + , Nat (Plus (BitVectorSize a) (BitVectorSize as))) + => BitRepr (a :. as) where + type BitVectorSize (a :. as) = Plus (BitVectorSize a) (BitVectorSize as) + toBitVector (a :. as) = B.shiftL (toBitVector a) (bitVectorSize as) + B..|. toBitVector as + fromBitVector x = a :. as + where + mask :: BitRepr a => a -> Integer + mask x = B.shiftL (1 :: Integer) (bitVectorSize x) - 1 + ys = x B..&. mask as + y = B.shiftR x (bitVectorSize as) B..&. mask a + a = fromBitVector y + as = fromBitVector ys + bitVectorSize (a :. as) = bitVectorSize a + bitVectorSize as + +instance BitRepr () where + type BitVectorSize () = $(tySize 0) + toBitVector = const 0 + fromBitVector = const () + +------------------------------------------------------------------------------- +-- Dumping HDL. + +data HDLGenState = HDLGenState { + -- errors, if we encounter any. + hdlgErrors :: [String] + -- Mapping from entities to their "real" names. + , hdlgGeneratedEntities :: Map.Map (String, Int) String + -- how deep we recurred? + , hdlgRecursionLevel :: Int + -- lines of generated text. In reverse order. + , hdlgTextLines :: [String] + -- nesting level. + , hdlgNestLevel :: Int + -- what kind of language we generate. + , hdlgLanguage :: HDL + -- set of defined names. + , hdlgDefinedNames :: Set.Set String + } + deriving (Prelude.Eq, Prelude.Ord, Show) +type HDLGen a = State HDLGenState a + +emptyHDLGenState hdl = HDLGenState { + hdlgErrors = [] + , hdlgGeneratedEntities = Map.empty + , hdlgRecursionLevel = 0 + , hdlgTextLines = [] + , hdlgNestLevel = 0 + , hdlgLanguage = hdl + , hdlgDefinedNames = Set.empty + } + +runHDLGeneration :: GenHDL a => HDL -> a -> (String, [String]) +runHDLGeneration hdl entity = (text, errors) + where + errors = hdlgErrors state + text = unlines $ reverse $ hdlgTextLines state + (_,state) = runState (generateHDL entity) (emptyHDLGenState hdl) + +generateLine :: String -> HDLGen () +generateLine s = modify $ \hdlg -> hdlg { + hdlgTextLines = (replicate (hdlgNestLevel hdlg) ' '++s) : hdlgTextLines hdlg + } + +generateEmptyLines :: Int -> HDLGen () +generateEmptyLines n = modify $ \hdlg -> hdlg { + hdlgTextLines = (replicate n "") ++ hdlgTextLines hdlg + } + +generateNest :: HDLGen a -> HDLGen a +generateNest act = do + nest <- liftM hdlgNestLevel get + modify $ \hdlg -> hdlg { hdlgNestLevel = nest + 4 } + x <- act + modify $ \hdlg -> hdlg { hdlgNestLevel = nest } + return x + +generateDashes :: HDLGen () +generateDashes = modify $ \hdlg -> hdlg { + hdlgTextLines = dashesLine (hdlgLanguage hdlg) (hdlgNestLevel hdlg) + : hdlgTextLines hdlg + } + where + dashesLine hdl n = concat [replicate n ' ',prefix hdl, replicate (79-n-2) '-'] + prefix hdl = case hdl of + VHDL -> "--" + Verilog -> "//" + +generateError :: String -> HDLGen () +generateError err = modify $ \hdlg -> hdlg { hdlgErrors = err : hdlgErrors hdlg} + +generateComment :: String -> HDLGen () +generateComment c = do + hdl <- liftM hdlgLanguage get + let commentPrefix = case hdl of + VHDL -> "--" + Verilog -> "//" + generateLine $ unwords [commentPrefix,c] + +generateDashesComment :: String -> HDLGen () +generateDashesComment c = do + generateDashes + generateComment c + +generateDefineName :: String -> HDLGen () +generateDefineName name = modify $ \hdlg -> hdlg { + hdlgDefinedNames = Set.insert name $ hdlgDefinedNames hdlg + } + +generateFilterDefined :: [a] -> (a -> String) -> HDLGen [a] +generateFilterDefined things nameProjection = do + defined <- liftM hdlgDefinedNames get + let things' = filter (not . flip Set.member defined . nameProjection) things + mapM (generateDefineName . nameProjection) things' + return things' + +class GenHDL a where + generateHDL :: a -> HDLGen () + +names :: HDLSignals s => s -> [String] +names s = map fst $ signalsWires s +entityPortsList dir signals = ( + map fst wiresKinds + ,map (\(name,kind) -> (name,unwords [name,":",dir,vhdlType kind])) wiresKinds) + where + wiresKinds = signalsWires signals + vhdlType BitSignal = "bit" + vhdlType (BusSignal width) = + "unsigned ("++show (width-1)++" downto 0)" +generateHDLForEntity :: (HDLSignals ins, HDLSignals outs, ClockList clocks) => + String -> Int -> ins -> outs -> clocks -> Netlist domain -> HDLGen () +generateHDLForEntity name index ins outs clocks netlist = do + hdl <- liftM hdlgLanguage get + n <- liftM (Map.lookup key . hdlgGeneratedEntities) get + case n of + Nothing -> do + ourName <- registerOurEntity + mapM_ subEntity $ netlistOperations netlist + case hdl of + VHDL -> vhdlText ourName + Verilog -> verilogText ourName + Just _ -> return () + where + key = (name, index) + registerOurEntity = do + names <- liftM (Set.fromList . Map.elems . hdlgGeneratedEntities) get + let newNames = map (name++) $ + map ('_':) $ map show [(1::Int)..] + let ourName = head $ filter (not . (`Set.member` names)) newNames + modify $ \hdlgs -> hdlgs { hdlgGeneratedEntities = Map.insert key ourName $ hdlgGeneratedEntities hdlgs } + return ourName + subEntity :: NetlistOp domain -> HDLGen () + subEntity (Instance entity ins outs) = do + generateHDL entity + subEntity _ = return () + generateEntityClocksResets clks = map addTypeDir $ clocks ++ resets + where + addTypeDir name = name ++ ": in std_logic" + clocks = clockListClocks clks + resets = clockListResets clks + generateVHDLDeclarations ops' = do + ops <- generateFilterDefined ops' fst + forM ops $ \(name, kind) -> do + let ty = case kind of + BitSignal -> "bit" + BusSignal n -> "unsigned ("++show (n-1)++" downto 0)" + generateLine $ concat ["signal ", name, " : ", ty,";"] + return () + declareOperationSignals :: NetlistOp domain -> HDLGen () + declareOperationSignals op = generateVHDLDeclarations $ case op of + Register _ wa wb -> signalsWires $ wa :. Nil + Assign wa op -> signalsWires $ wa :. Nil + Instance entity ins outs -> signalsWires outs + vhdlOperation :: NetlistOp domain -> HDLGen () + vhdlOperation op = case op of + Register def wa wb -> do + let c = wireClock wa + let cn = clockName c + let edge = (if clockFrontEdge c then "rising_edge" else "falling_edge") + ++"("++cn++")" + let rn = clockResetName c + let resetFunc = + rn ++ " = " + ++ (if clockResetPositive c then "'1'" else "'0'") + generateLine $ "process ("++cn++", "++rn++") is" + generateLine $ "begin" + generateNest $ do + generateLine $ unwords ["if",resetFunc, "then"] + generateNest $ vhdlOperation (Assign wa (constant def)) + generateLine $ unwords ["elsif",edge, "then"] + generateNest $ vhdlOperation (Assign wa wb) + generateLine "end if;" + generateLine $ "end process;" + Assign wa op -> do + generateLine $ concat + [signalName wa, " <= " + ,opToHDL VHDL op, ";"] + Instance entity ins outs -> do + let (eins, eouts, eclks) = getInputsOuputsClocks entity + let insNames = names ins + let outsNames = names outs + let einsNames = names eins + let eoutsNames = names eouts + let clocks = nub $ clockListClocks eclks + let resets = nub $ clockListResets eclks + let connect a b = a ++" => " ++ b + let allNames = zipWith connect insNames einsNames + ++ zipWith connect outsNames eoutsNames + ++ map (\c -> connect c c) clocks + ++ map (\c -> connect c c) resets + let withCommas = zipWith (++) (" ":repeat ", ") allNames + generateLine "entity (" + generateNest $ mapM generateLine withCommas + generateLine ");" + vhdlText name = do + generateEmptyLines 2 + generateDashesComment $ "Entity declaration and architecture for "++name++"." + generateEmptyLines 1 + generateLine "library ieee;" + generateLine "use ieee.std_logic_1164.all;" + generateLine "use ieee.numeric_bit.all;" + generateEmptyLines 1 + generateLine $ "entity "++name++" is" + generateNest $ do + generateLine "port (" + let (inputsNames,inputs) = + entityPortsList "in" ins + let (outputsNames, outputs) = + entityPortsList "out" outs + let clockResets = generateEntityClocksResets clocks + let inouts = inputs ++ outputs + let allSignals = (map snd inouts) ++ clockResets + let signals = reverse $ + zipWith (++) (reverse allSignals) ("" : repeat ";") + mapM generateDefineName $ map fst inouts + generateNest $ do + mapM generateLine signals + generateLine ");" + return $ inputsNames ++ outputsNames + generateLine $ "end entity "++name++";" + generateEmptyLines 2 + generateLine $ "architecture hhdl_generated of "++name++" is" + generateNest $ do + addSupportFunctions + mapM declareOperationSignals $ netlistOperations netlist + generateLine $ "begin" + generateNest $ do + mapM vhdlOperation $ netlistOperations netlist + generateLine $ "end architecture hhdl_generated;" + return () + + verilogText name = do + generateLine $ "Verilog text for entity "++name + + addSupportFunctions = mapM generateLine [ + replicate 60 '-' + , "-- Supporting functions." + , "" + , "pure function select_func(s : in bit; t, f : in bit) return bit is" + , "begin" + , " if s = '1' then" + , " return t;" + , " else" + , " return f;" + , " end if;" + , "end function select_func;" + , "" + , "pure function select_func(s : in bit; t, f : in unsigned) return unsigned is" + , "begin" + , " if s = '1' then" + , " return t;" + , " else" + , " return f;" + , " end if;" + , "end function select_func;" + , "" + , "pure function bit_equality(a, b : in bit) return bit is" + , "begin" + , " if a = b then" + , " return '1';" + , " else" + , " return '0';" + , " end if;" + , "end function bit_equality;" + , "" + , "pure function bit_equality(a, b : in unsigned) return bit is" + , "begin" + , " if a = b then" + , " return '1';" + , " else" + , " return '0';" + , " end if;" + , "end function bit_equality;" + , "" + ] + +instance GenHDL (Comb ins outs) where + generateHDL (Comb name index ins outs netlist) = do + generateHDLForEntity name index ins outs Nil netlist + +instance GenHDL (Clocked cs ins outs) where + generateHDL (Clocked clocks name index ins outs netlist) = do + generateHDLForEntity name index ins outs clocks netlist + +instance GenHDL (Mealy c ins outs) where + generateHDL (Mealy c name index ins outs netlist) = do + generateHDLForEntity name index ins outs (c :. Nil) netlist + +writeHDLText :: GenHDL a => HDL -> a -> (String -> IO ()) -> IO () +writeHDLText hdl entity write = do + let (text, errors) = runHDLGeneration hdl entity + write text + case errors of + [] -> return () + errs -> do + putStrLn $ "\n\n\nErrors:" + mapM putStrLn errs + putStrLn "------------------" + putStrLn $ "Total " ++ show (length errs) ++ " errors in HDL generation." + +------------------------------------------------------------------------------- +-- Bit vectors. + +data BV size = BV Integer + +instance Nat size => BitRepr (BV size) where + type BitVectorSize (BV size) = size + toBitVector (BV i) = i + fromBitVector i = r + where + r = BV (i B..&. bitMask r) + +instance Nat size => IntegerConstant (BV size) where + fromInteger i = fromBitVector i + +instance Show (BV size) where + showsPrec n (BV i) = (concat [o,Text.Printf.printf "BV 0x%x" i,c]++) + where + (o,c) + | n > 10 = ("(",")") + | otherwise = ("","") + +instance Nat size => Eq (BV size) where + type EqResult (BV size) = Bool + a == b = toBitVector a == toBitVector b + a /= b = toBitVector a /= toBitVector b + +_toSelBusSizeBitVector :: AlgTypeBitEnc a => a -> BV (SelectorBusSize a) +_toSelBusSizeBitVector = undefined + +_toSelBusSizeBitVectorWireExpr :: AlgTypeBitEnc a => Wire c a -> BV (SelectorBusSize a) +_toSelBusSizeBitVectorWireExpr = undefined + +_toArgsBusSizeBitVector :: AlgTypeBitEnc a => Wire c a -> Wire c (BV (ArgsBusSize a)) +_toArgsBusSizeBitVector = undefined + +------------------------------------------------------------------------------- +-- Netlist operations. + +addNetlistOperation op = + modify $ \nlms -> nlms { + nlmsNetlist = Netlist $ op : netlistOperations (nlmsNetlist nlms) + } +register :: (ClockAllowed c clocks, BitRepr a, Show a) => a -> Wire c a -> NLM clocks (Wire c a) +register resetValue computedValue = do + w <- tempWire + modify $ \nlms -> nlms { + nlmsNetlist = Netlist (Register resetValue w computedValue : netlistOperations (nlmsNetlist nlms)) + } + return w + +instantiate :: (Instantiable entity, ClockSubset (EntityClocks entity) clocks + , WiresList (EntityIns entity), WiresList (EntityOuts entity)) => + entity -> EntityIns entity -> NLM clocks (EntityOuts entity) +instantiate entity ins = do + outs <- mkWireList Nothing + addNetlistOperation $ Instance entity ins outs + return outs + +assignWire :: (BitRepr ty) => Wire c ty -> NLM registers (Wire c ty) +assignWire what = do + assignFlattened what + +assignWithForcedCopy n wire = do + t <- mkWire n + addNetlistOperation $ Assign t wire + return t + +assignFlattened :: (BitRepr ty) => Wire c ty -> NLM registers (Wire c ty) +assignFlattened w@(Wire _ _) = return w +assignFlattened (Expr op) = do + op <- opFlatten op + assignWithForcedCopy Nothing $ Expr op + +extendZero :: (Nat src, Nat dest) => Wire c (BV src) -> Wire c (BV dest) +extendZero what = Expr $ Extend False what + +extendSign :: (Nat src, Nat dest) => Wire c (BV src) -> Wire c (BV dest) +extendSign what = Expr $ Extend True what + +castWires :: (BitRepr src, BitRepr res, BitVectorSize src ~ BitVectorSize res) => + Wire c src -> Wire c res +castWires what = Expr $ CastWires what + +_runPureNetlist :: NLM Nil a -> NLM clocks a +_runPureNetlist action = do + s <- get + let (a,s') = runState action (copyNLMS s) + put (copyNLMSBack s' s) + return a + where + copyNLMS (NLMS (Netlist netlist) cntr) = NLMS (Netlist []) cntr + copyNLMSBack :: NLMS Nil -> NLMS clocks -> NLMS clocks + copyNLMSBack (NLMS (Netlist ops1) cntr) (NLMS (Netlist ops2) _) + = NLMS (Netlist $ copyOps ops1 ops2) cntr + copyOps :: [NetlistOp Nil] -> [NetlistOp clocks] -> [NetlistOp clocks] + copyOps [] ops2 = ops2 + copyOps (Assign to what : ops1) ops2 = copyOps ops1 (ops2++[Assign to what]) + copyOps (Instance ent ins outs : ops1) ops2 = copyOps ops1 (ops2++[Instance ent ins outs]) + +------------------------------------------------------------------------------- +-- Operations for expressions. + +data Extend c dest where + -- bool flag is whether we're using sign (we are when True). + Extend :: (Nat src, Nat res) => Bool -> Wire c (BV src) -> Extend c (BV res) + +instance BitRepr res => WireOp (Extend c res) where + type WireOpType (Extend c res) = res + opToHDL hdl op@(Extend signExtendFlag arg) + | widen = widenExpr + | narrow = narrowExpr + | otherwise = subExpr + where + destSize = wireOpBusSize op + srcSize = wireOpBusSize arg + widen = destSize > srcSize + narrow = destSize > srcSize + delta = destSize - srcSize + sign = case hdl of + VHDL -> subExpr ++"("++show (srcSize-1)++")" + Verilog -> subExpr ++"["++show (srcSize-1)++"]" + extension = case hdl of + VHDL -> if signExtendFlag + then concat $ intersperse " & " (replicate delta sign) + else show (replicate delta '0') + Verilog -> if signExtendFlag + then concat $ intersperse ", " (replicate delta sign) + else show (replicate delta '0') + subExpr = opToHDL hdl arg + widenExpr = case hdl of + VHDL -> unwords [extension, subExpr] + Verilog -> "{"++concat [extension, ", ", subExpr]++"}" + narrowExpr = case hdl of + VHDL -> subExpr ++"("++show (destSize-1)++" downto 0)" + opFlatten (Extend se a) = liftM (Extend se) $ assignFlattened a + +data CastWires c res where + -- bool flag is whether we're using sign (we are when True). + CastWires :: (BitRepr src, BitRepr res, BitVectorSize src ~ BitVectorSize res) => + Wire c src -> CastWires c res + +instance BitRepr res => WireOp (CastWires c res) where + type WireOpType (CastWires c res) = res + opToHDL hdl (CastWires op) = opToHDL hdl op + opFlatten (CastWires op) = do + op <- assignFlattened op + return $ CastWires op + +class BitRepr (WireOpListTypes a) => WireOpList a where + type WireOpListTypes a +-- type WireOpListClock a + opsToHDL :: HDL -> a -> [String] +instance WireOpList Nil where + type WireOpListTypes Nil = Nil + opsToHDL hdl = const [] +instance (WireOp x, WireOpList xs + , Nat (Plus (BitVectorSize (WireOpType x)) (BitVectorSize (WireOpListTypes xs)))) => WireOpList (x :. xs) where + type WireOpListTypes (x :. xs) = WireOpType x :. WireOpListTypes xs + opsToHDL hdl (a :. as) = opToHDL hdl a : opsToHDL hdl as + +data SplitWiresOp c r where + SplitWiresOp :: BitRepr s => Wire c s -> Int -> SplitWiresOp c r + +instance BitRepr r => WireOp (SplitWiresOp c r) where + type WireOpType (SplitWiresOp c r) = r + opToHDL hdl x@(SplitWiresOp wire ofs) = case hdl of + VHDL + | rSize > 1 -> unwords [subExpr, "(", show (rSize+ofs-1), "downto", show ofs, ")"] + | otherwise -> unwords [subExpr, "(", show ofs,")"] + Verilog -> error "Verilog SplitWiresOp!!!" + where + rSize = opTypeSize x + subExpr = opToHDL hdl wire + opFlatten (SplitWiresOp wire ofs) = liftM (\w -> SplitWiresOp w ofs) $ assignFlattened wire + +type family SplitProjection c w +class BitRepr w => SplitWires w where + splitWires :: Wire c w -> SplitProjection c w + +instance (BitRepr a, BitRepr b, Nat (Plus (BitVectorSize a) (BitVectorSize b)), Nat (BitVectorSize(a,b))) => BitRepr (a,b) where + type BitVectorSize (a,b) = Plus (BitVectorSize a) (BitVectorSize b) + toBitVector (x0,x1) = B.shiftL (toBitVector x0) (bitVectorSize x1) B..|. toBitVector x1 + fromBitVector v = (x0,x1) + where + x1 = fromBitVector v + x0 = fromBitVector (B.shiftR v (bitVectorSize x1)) + +type instance SplitProjection c (a,b) = (Wire c a, Wire c b) +instance (BitRepr a, BitRepr b, BitRepr (a,b)) => SplitWires (a,b) where + splitWires wab = (wa, wb) + where + wa = Expr $ SplitWiresOp wab (wireBusSize wb) + wb = Expr $ SplitWiresOp wab 0 + +splitWires2 :: (BitRepr a, BitRepr b, BitRepr (a,b)) => Wire clk (a,b) -> (Wire clk a, Wire clk b) +splitWires2 = splitWires + +$(liftM concat $ forM [3..8] $ \n -> let + typeNames' = map (\i -> TH.mkName ("t_"++show i)) [1..n] + typeNames = map TH.VarT typeNames' + ty = foldl TH.AppT (TH.TupleT n) typeNames + clkN = TH.mkName "clk" + clk = TH.VarT clkN + wireTy ty = TH.ConT (TH.mkName "Wire") `TH.AppT` clk `TH.AppT` ty + wiresTy = foldl TH.AppT (TH.TupleT n) $ map wireTy typeNames + bitReprP ty = TH.ClassP (TH.mkName "BitRepr") [ty] + bitVectorSizeT ty = TH.ConT (TH.mkName "BitVectorSize") `TH.AppT` ty + commonCxt = map bitReprP typeNames + brCxt = TH.ClassP (TH.mkName "Nat") [bitVectorSizeT ty] : commonCxt + swCxt = bitReprP ty : commonCxt + argNames = map (\i -> TH.mkName ("x"++show i)) [1..n] + shiftNames = map (\i -> TH.mkName ("s"++show i)) [1..n] + argVars = map TH.VarE argNames + prevArgs = Prelude.scanr (:) [] argVars + sumWidths ws = foldr (\a b -> TH.InfixE (Just a) (TH.VarE $ TH.mkName "+") (Just b)) (TH.LitE $ TH.IntegerL 0) $ map (TH.AppE (TH.VarE (TH.mkName "wireBusSize"))) ws + def v widths = flip (TH.ValD (TH.VarP v)) [] $ TH.NormalB $ + TH.ConE (TH.mkName "Expr") `TH.AppE` + (TH.ConE (TH.mkName "SplitWiresOp") + `TH.AppE` vV `TH.AppE` sumWidths widths) + defs = zipWith def argNames (tail prevArgs) + vN = TH.mkName "v" + vV = TH.VarE vN + bitVecSizeTy = TH.TySynInstD (TH.mkName "BitVectorSize") [ty] $ + foldl1 (\a b -> TH.ConT (TH.mkName "Plus") `TH.AppT` a `TH.AppT` b) $ map bitVectorSizeT typeNames + defShift Nothing def arg = TH.ValD (TH.VarP def) (TH.NormalB $ TH.LitE $ TH.IntegerL 0) [] + defShift (Just prev) def arg = TH.ValD (TH.VarP def) (TH.NormalB $ TH.InfixE (Just (TH.VarE prev)) (TH.VarE $ TH.mkName "+") (Just sz)) [] + where + sz = TH.VarE (TH.mkName "bitVectorSize") `TH.AppE` TH.VarE arg + shiftDefs = Prelude.zipWith3 defShift (map Just (Prelude.init shiftNames) ++ [Nothing]) shiftNames argNames + toBVE = Prelude.foldr1 (\x y -> TH.InfixE (Just x) (TH.VarE $ TH.mkName "Data.Bits..|.") (Just y)) + $ zipWith (\x s -> TH.VarE (TH.mkName "Data.Bits.shiftL") + `TH.AppE` (TH.VarE (TH.mkName "toBitVector") `TH.AppE` TH.VarE x) + `TH.AppE` TH.VarE s) argNames shiftNames + toBV = TH.FunD (TH.mkName "toBitVector") + [TH.Clause [TH.TupP $ map TH.VarP argNames] (TH.NormalB toBVE) shiftDefs] + fromBVEShiftDef x s pxs = [ + TH.ValD (TH.VarP x) (TH.NormalB convertedX) [] + , TH.ValD (TH.VarP s) (TH.NormalB shiftE) [] + ] + where + vx = TH.VarE x + convertedX = TH.VarE (TH.mkName "fromBitVector") `TH.AppE` shiftedV + shiftedV = TH.VarE (TH.mkName "Data.Bits.shiftR") `TH.AppE` vV `TH.AppE` TH.VarE s + shiftE = case pxs of + Nothing -> TH.LitE $ TH.IntegerL 0 + Just (x,s) -> TH.InfixE + (Just $ TH.VarE (TH.mkName "bitVectorSize") `TH.AppE` TH.VarE x) + (TH.VarE $ TH.mkName "+") + (Just $ TH.VarE s) + shiftArgs as = map Just (tail as) ++ [Nothing] + fromBVEShiftDefs = concat $ zipWith3 fromBVEShiftDef argNames shiftNames (shiftArgs $ zip argNames shiftNames) + fromBVE = TH.TupE $ map TH.VarE argNames + fromBV = TH.FunD (TH.mkName "fromBitVector") + [TH.Clause [TH.VarP vN] (TH.NormalB fromBVE) fromBVEShiftDefs] + split = TH.FunD (TH.mkName "splitWires") + [TH.Clause [TH.VarP vN] (TH.NormalB $ TH.TupE argVars) defs] + specializedSplitN = TH.mkName $ "splitWires"++show n + decls = [ TH.InstanceD swCxt (TH.ConT (TH.mkName "SplitWires") `TH.AppT` ty) [split] + , TH.TySynInstD (TH.mkName "SplitProjection") [clk,ty] wiresTy + , TH.InstanceD brCxt (TH.ConT (TH.mkName "BitRepr") `TH.AppT` ty) [bitVecSizeTy, toBV, fromBV] + , TH.SigD specializedSplitN $ TH.ForallT (map TH.PlainTV $ clkN : typeNames') brCxt $ (TH.AppT (TH.AppT TH.ArrowT $ wireTy ty) wiresTy) + , TH.FunD specializedSplitN [TH.Clause [] (TH.NormalB $ TH.VarE (TH.mkName "splitWires")) []] + ] + in do +-- runIO $ mapM (putStrLn . show . ppr) decls + return decls + ) + +_castAlgTypeToPair :: (Nat (Plus (SelectorBusSize a) (ArgsBusSize a)), BitRepr a + , Plus (SelectorBusSize a) (ArgsBusSize a) ~ BitVectorSize a, AlgTypeBitEnc a) => Wire c a -> Wire c (BV (SelectorBusSize a), BV (ArgsBusSize a)) +_castAlgTypeToPair w = castWires w +_splitAlgType :: (Plus (SelectorBusSize a) (ArgsBusSize a) ~ BitVectorSize a, Nat (Plus (SelectorBusSize a) (ArgsBusSize a)), AlgTypeBitEnc a, BitRepr a) => Wire c a -> (Wire c (BV (SelectorBusSize a)), Wire c (BV (ArgsBusSize a))) +_splitAlgType w = splitWires $ _castAlgTypeToPair w +_castArgsWires :: (Nat (ArgsBusSize a), AlgTypeBitEnc a, BitRepr a, BitRepr b) => Wire c a -> Wire c (BV (ArgsBusSize a)) -> Wire c b +_castArgsWires a w = r + where + r = castWires (extendZero w) + +data Join c w where + Join :: (BitRepr a, BitRepr b) => Wire c a -> Wire c b -> Join c (a :. b) + +instance BitRepr w => WireOp (Join c w) where + type WireOpType (Join c w) = w + opToHDL hdl (Join l r) = case hdl of + VHDL -> unwords ["(",opToHDL hdl l,"&",opToHDL hdl r,")"] + Verilog -> concat ["{",opToHDL hdl l,",",opToHDL hdl r,"}"] + opFlatten (Join l r) = liftM2 Join (assignFlattened l) (assignFlattened r) + +infixr 5 & +(&) :: (BitRepr a, BitRepr b, Nat (Plus (BitVectorSize a) (BitVectorSize b))) => Wire c a -> Wire c b -> Wire c (a :. b) +a & b = Expr $ Join a b + +data Equality c w where + -- first is the flag for equality testing, if true. + Equality :: BitRepr w => Bool -> Wire c w -> Wire c w -> Equality c Bool + +instance BitRepr w => WireOp (Equality c w) where + type WireOpType (Equality c w) = w + opToHDL hdl (Equality eq l r) = case hdl of + VHDL -> concat ["bit_equality( ", opToHDL hdl l,", ", opToHDL hdl r,")"] + Verilog -> error "Equality Verilog!!!" + where + op = case hdl of + VHDL -> if eq then "=" else "/=" + Verilog -> if eq then "==" else "!=" + opFlatten (Equality eq l r) = liftM2 (Equality eq) (assignFlattened l) (assignFlattened r) + +instance (Eq w, EqResult w ~ Bool, BitRepr w) => Eq (Wire c w) where + type EqResult (Wire c w) = Wire c Bool + a == b = Expr $ Equality True a b + a /= b = Expr $ Equality False a b + +data Select c w where + Select :: Wire c Bool -> Wire c a -> Wire c a -> Select c a + +instance BitRepr a => WireOp (Select c a) where + type WireOpType (Select c a) = a + opToHDL hdl (Select c l r) = case hdl of + VHDL -> concat["select_func(",cv, ", ", lv,", ",rv,")"] + Verilog -> error "Verilog Select!!!" + where + cv = opToHDL hdl c + lv = opToHDL hdl l + rv = opToHDL hdl r + opFlatten (Select c l r) = do + c <- assignFlattened c + l <- assignFlattened l + r <- assignFlattened r + return $ Select c l r + +selectWires :: BitRepr a => Wire c Bool -> Wire c a -> Wire c a -> Wire c a +selectWires sel true false = Expr $ Select sel true false + +------------------------------------------------------------------------------- +-- Pattern matching. +-- We hardwire (pun intended) Wire(s) into Patterns because we can match +-- only on bit vectors. And those bit vectors get transferred by Wire(s). + +type family ConcatPatList a b +type instance ConcatPatList a b = ConcatWiresList (a :. b) +--type instance ConcatPatList (x :. xs) ys = x :. (ConcatPatList xs ys) + +class (WiresList (ConcatWiresList a)) => WiresListConcat a where + type ConcatWiresList a + concatWiresList :: a -> ConcatWiresList a + +instance WiresListConcat Nil where + type ConcatWiresList Nil = Nil + concatWiresList Nil = Nil + +instance WiresList as => WiresListConcat (Nil :. as) where + type ConcatWiresList (Nil :. as) = as + concatWiresList (Nil :. as) = as + +instance (WiresListConcat (as :. bs), WiresList (a :. ConcatWiresList (as :. bs))) => WiresListConcat ((a :. as) :. bs) where + type ConcatWiresList ((a :. as) :. bs) = a :. ConcatWiresList (as :. bs) + concatWiresList ((a :. as) :. bs) = a :. concatWiresList (as :. bs) + +data PatMatch v r where + PatMatch :: (Wire c v -> NLM Nil (Wire c Bool, Wire c result)) + -> PatMatch (Wire c v) (Wire c result) + +data Pattern w o where + Pattern :: {unPattern :: WiresList o => (Wire c w -> NLM Nil (o, Wire c Bool))} -> Pattern (Wire c w) o + +match :: (ClockAllowed c registers, BitRepr v, BitRepr r) => Wire c v + -> [PatMatch (Wire c v) (Wire c r)] -> NLM registers (Wire c r) +match v ms = do + w <- assignWire v + _runPureNetlist $ reduceMatches w ms + where + reduceMatches :: BitRepr r => Wire c v -> [PatMatch (Wire c v) (Wire c r)] -> NLM Nil (Wire c r) + reduceMatches w [] = error "Empty list of pattern matches!" + reduceMatches w [PatMatch pm] = do + (_,r) <- pm w + return r + reduceMatches w pms = do + pms' <- reduceMatchesByTwo pms + reduceMatches w pms' + reduceMatchesByTwo :: BitRepr r => [PatMatch (Wire c v) (Wire c r)] -> NLM Nil [PatMatch (Wire c v) (Wire c r)] + reduceMatchesByTwo [] = return [] + reduceMatchesByTwo [pm] = return [pm] + reduceMatchesByTwo (PatMatch pm1:PatMatch pm2:pms) = do + let pm = PatMatch $ \v -> do + (f1,r1) <- pm1 v + (f2,r2) <- pm2 v + fw <- assignWire $ f1 || f2 + sw <- assignWire $ selectWires f1 r1 r2 + return (fw, sw) + pms' <- reduceMatchesByTwo pms + return $ pm : pms' + +infixl 8 --> +(-->) :: WiresList wires => Pattern (Wire c t) wires -> (wires -> NLM Nil (Wire c result)) + -> PatMatch (Wire c t) (Wire c result) +(Pattern p) --> f = PatMatch $ \w -> do + (ws,flag) <- p w + r <- f ws + return (flag, r) + +-- |Constant match. +pcst :: (Eq a, EqResult a ~ Bool, Eq (Wire c a), Show a, BitRepr a) => a -> Pattern (Wire c a) Nil +pcst c = Pattern $ \w -> return (Nil, w == constant c) + +pvar :: BitRepr a => Pattern (Wire c a) (Wire c a :. Nil) +pvar = Pattern $ \w -> return (w :. Nil, constant True) + +pwild :: BitRepr a => Pattern (Wire c a) Nil +pwild = Pattern $ \w -> return (Nil, constant True) + +-- Pattern matching for some Prelude types. +$(reifyGenerateMakeMatch [''Maybe, ''Either, ''Bool]) diff --git a/src/Hardware/HHDL/TH.hs b/src/Hardware/HHDL/TH.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/TH.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE TemplateHaskell, PatternGuards #-} + +module Hardware.HHDL.TH(reifyGenerateMakeMatch, generateMakeMatches) where + +import Control.Monad +import Data.List +import Language.Haskell.TH + +import Hardware.HHDL.TyLeA + +------------------------------------------------------------------------------- +-- Build BitRepr instance, make and pattern combinators for algebraic types. +-- +-- For every constructor Cons in declarations we will build mkCons with Cons' +-- arguments wrapped into WireOps amd pCons pattern match which matches +-- constructor against Wire. + +generateMakeMatches :: Q [Dec] -> Q [Dec] +generateMakeMatches decs = do + ds <- decs + liftM concat $ forM ds generateMakeMatch + +reifyGenerateMakeMatch :: [Name] -> Q[Dec] +reifyGenerateMakeMatch names = liftM concat $ mapM checkReifyGenerate names + where + checkReifyGenerate n = do + i <- reify n + case i of + TyConI dec -> generateMakeMatchGen dec + _ -> error $ show n ++ " does not reify to type declaration." + +logGen s = runIO $ appendFile "gen" $ s++"\n" + +generateMakeMatch dec = liftM (dec:) $ generateMakeMatchGen dec + +generateMakeMatchGen :: Dec -> Q [Dec] +generateMakeMatchGen d@(DataD cxt name args conses _) + | not $ null cxt = declError "Context is not empty." + | Nothing <- bindersAreVars = declError "Only variable args are supported." + | Just argVars <- bindersAreVars = do + let justTyName = mkName $ nameBase name + ds <- forM (zip [0..] conses) (uncurry $ generateConMakeMatch justTyName argVars) + argsBusSize <- generateArgsBusSize justTyName argVars conses + selBusSize <- generateSelBusSize justTyName argVars conses + bitReprIns <- generateBitRepr justTyName argVars conses + let result = argsBusSize : selBusSize : bitReprIns ++ concat ds + logGen $ unlines (map (show . ppr) result) + return result + where + declError e = error $ unlines [ + e + , "", "" + , "Declaration:" + , show (ppr d) + ] + bindersAreVars = mapM binderIsVar args + binderIsVar (PlainTV v) = return v + binderIsVar _ = Nothing +generateMakeMatchGen d = return [] + +generateConMakeMatch :: Name -> [Name] -> Integer -> Con -> Q [Dec] +generateConMakeMatch dataName args selectorIndex c@(NormalC conName types) = do + return [makeType, makeFunc, matchTypeD, matchFunc] +-- return [matchTypeD, matchFunc] + where + matchName = mkName $ "p"++nameBase conName + matchFunc = FunD matchName + [Clause argPatterns (NormalB $ ConE (mkName "Pattern") `AppE` (LamE [wP] (DoE matchStats))) []] + wN = mkName "w" + wP = VarP wN + wV = VarE wN + returnStat e = NoBindS $ VarE (mkName "return") `AppE` e + cN = mkName "c" + cP = VarP cN + cV = VarE cN + asN = mkName "as" + asP = VarP asN + asV = VarE asN + conpN = mkName "conp" + conpV = VarE conpN + conpP = VarP conpN + resultingCondN = mkName "resultingCond" + resultingCondV = VarE resultingCondN + resultingCondP = VarP resultingCondN + argumentsWiresN = mkName "argumentsWires" + argumentsWiresV = VarE argumentsWiresN + argumentsWiresP = VarP argumentsWiresN + constructorSplit = VarE (mkName "_splitAlgType") `AppE` wV + argMatch (argPat, argWire, matchResult, matchCond) = BindS + (TupP [VarP matchResult, VarP matchCond]) f + where + unpatterned = VarE (mkName "unPattern") `AppE` VarE argPat + f = unpatterned `AppE` VarE argWire + splitWiresN e + | length types > 1 = VarE (mkName $ "splitWires"++show (length types)) + `AppE` e + | length types == 1 = e + splitAssign = case types of + [] -> [] + [_] -> [LetS + [ValD (VarP $ head aws) (NormalB $ castWires $ extendZero asV) []]] + xs -> [LetS + [ ValD argumentsWiresP (NormalB $ castWires $ extendZero asV) [] + , ValD (TupP $ map VarP aws) (NormalB $ splitWiresN argumentsWiresV) []]] + consT a b = ConT (mkName ":.") `AppT` a `AppT` b + consE a b = ConE (mkName ":.") `AppE` a `AppE` b + nil = ConE nilN + assignWire p e = BindS p $ VarE (mkName "assignWire") `AppE` e + matchStats = concat [ + [LetS [ValD (TupP [cP,asP]) (NormalB constructorSplit) []]] + , splitAssign + --, [BindS conpP (VarE (mkName "assignWire") `AppE` (VarE (mkName "_fixAsBoolWire") `AppE` (InfixE (Just cV) (VarE $ mkName "==") (Just $ VarE (mkName "asTypeOf") `AppE` (LitE $ IntegerL $ fromIntegral selectorIndex) `AppE` cV ))))] + , [assignWire conpP (InfixE (Just cV) (VarE $ mkName "==") (Just $ VarE (mkName "asTypeOf") `AppE` (LitE $ IntegerL $ fromIntegral selectorIndex) `AppE` cV ))] + , map argMatch $ zip4 argNames aws mrs mcs + , [assignWire resultingCondP $ foldr and conpV $ map VarE mcs] + , [returnStat $ TupE [concatWLs mrs, resultingCondV]] + ] + where + and a b = InfixE (Just a) (VarE $ mkName "&&") (Just b) + concatWL a = VarE (mkName "concatWiresList") `AppE` a + concatWLs vs = concatWL $ foldr consE nil $ map VarE mrs + matchTypeD = SigD matchName matchType + concatTyLists a b = ConT (mkName "ConcatPatList") `AppT` a `AppT` b + patternT ty o = ConT (mkName "Pattern") `AppT` wireT ty `AppT` o + wireT ty = ConT (mkName "Wire") `AppT` clkT `AppT` ty + nilN = mkName "Nil" + nilT = ConT nilN + mkMatchType _ t _ [] [] = let + in (patternT resultT nilT, nilT, [], []) + mkMatchType n t os wss [] = let + concatenated = add concatTyLists $ reverse $ map VarT wss + listOfTyLists = foldr consT nilT $ reverse $ map VarT wss + in (t $ patternT resultT $ ConT (mkName "ConcatWiresList") `AppT` listOfTyLists, concatenated, os, wss) + mkMatchType n t os wss (ty:tys) = + mkMatchType (n+1) t' (out:os) (out:wss) tys + where + t' = t . (patternT ty (VarT out) `arr`) + arr a b = ArrowT `AppT` a `AppT` b + out = mkName $ "o_"++show n + baseDataTy = foldl AppT (ConT dataName) $ map VarT args + matchType = ForallT (map PlainTV vars) (nub context) ty + where + bitReprInst ty = ClassP (mkName "BitRepr") [ty] + bitVectorNatInst ty = ClassP (mkName "Nat") [bitVectorSize ty] + wiresList c = ClassP (mkName "WiresList") [c] + context = --wiresList cs + {-:-} bitReprInst baseDataTy + : bitVectorNatInst baseDataTy + : ClassP (mkName "AlgTypeBitEnc") [baseDataTy] + : map (wiresList . VarT) os + ++ map (bitReprInst . VarT) args + ++ map (bitVectorNatInst . VarT) args + ++ argumentsNat + ++ [resultsWiresList] + (ty,cs,os,vs) = mkMatchType 0 id [] [] (map snd types) + vars = nub $ tyVars ty + tyVars (AppT a b) = tyVars a ++ tyVars b + tyVars (VarT v) = [v] + tyVars _ = [] + clk = mkName "c" + clkT = VarT clk + nameMake = mkName $ "mk"++nameBase conName + wire = AppT (ConT $ mkName "Wire") clkT + resultT = foldl AppT (ConT dataName) (map VarT args) + mkTy [] = AppT wire resultT + mkTy (t:ts) = AppT (AppT ArrowT (AppT wire (snd t))) (mkTy ts) + typesVars = nub $ concatMap (typeVars . snd) types ++ args + typeVars (AppT a b) = typeVars a ++ typeVars b + typeVars (VarT v) = [v] + typeVars _ = [] + mkCxt _ [] = [] + mkCxt brs (ty:ts) = + bitRepr ++ mkCxt (ty:brs) ts + where + bitRepr + | ty `elem` brs = [] + | not (anyVars ty) = [] + | otherwise = + [ClassP (mkName "BitRepr") [ty]] + anyVars (AppT a b) = anyVars a || anyVars b + anyVars (VarT _) = True + anyVars _ = False + context = nub $ mkCxt [] (map VarT args ++ map snd types)++algTypeCxt + ++ sumNat (map snd types) ++ [wholeTypeNat] + ++ argumentsNat + argumentsNat = map sumNat $ init $ tails types + where + sumNat ts = ClassP (mkName "Nat") [foldl1 plusT $ map (bitVectorSize . snd) ts] + resultsWiresList = ClassP (mkName "WiresListConcat") + [foldr consT nilT $ map (VarT . mkName) $ map (("o_"++) . show) $ zipWith const [0..] types] + bitVectorSize ty = ConT (mkName "BitVectorSize") `AppT` ty + natPred ty = ClassP (mkName "Nat") [ty] + plusT a b = ConT (mkName "Plus") `AppT` a `AppT` b + sumNat [] = [] + sumNat [ty] + | anyVars ty = [natPred ty] + | otherwise = [] + sumNat (ty:tys) = sumNat tys ++ thisNat ++ [sumNats] + where + thisNat + | anyVars ty = [natPred $ bitVectorSize ty] + | otherwise = [] + (t:ts) = map bitVectorSize $ (ty:tys) + sumNats = natPred (add plusT $ t:ts) + add f [a] = a + add f (a:as) = f a (add f as) + selectorBusSize ty = ConT selectorBusSizeName `AppT` ty + argsBusSize ty = ConT (mkName "ArgsBusSize") `AppT` ty + wholeTypeNat = natPred (foldl1 plusT $ selectorBusSize resultT : argsBusSize resultT : []) + algTypeCxt + | not $ null args = [ClassP (mkName "AlgTypeBitEnc") [resultT]] + | otherwise = [] + makeType = SigD nameMake $ ForallT (map PlainTV $ clk : typesVars) context $ mkTy types + namesWithPrefix pfx = zipWith (\i _ -> mkName $ pfx++"_"++show i) [0..] types + argNames = namesWithPrefix "a" + aws = namesWithPrefix "argumentWire" + mrs = namesWithPrefix "matchResult" + mcs = namesWithPrefix "matchCond" + argPatterns = map VarP argNames + argsVector = case map VarE argNames of + [] -> VarE (mkName "constant") `AppE` LitE (IntegerL 0) + (as) -> extendZero $ castWires $ add join as + resultN = mkName "result" + resultV = VarE resultN + resultD = ValD (VarP resultN) + (NormalB (castWires (selectorV `join` argsVectorV))) + [] + selectorN = mkName "selector" + selectorV = VarE selectorN + selectorD = ValD (VarP selectorN) (NormalB sel) [] + where + sel = VarE (mkName "constant") `AppE` e + e = InfixE + (Just $ LitE (IntegerL selectorIndex)) + (VarE $ mkName "asTypeOf") + (Just $ VarE (mkName "_toSelBusSizeBitVectorWireExpr") `AppE` resultV) + castWires x = VarE (mkName "castWires") `AppE` x + join a b = InfixE (Just a) (VarE $ mkName "&") (Just b) + argsVectorN = mkName "argsVector" + argsVectorV = VarE argsVectorN + extendZero e = (VarE $ mkName "extendZero") `AppE` e + argsVectorD = ValD (VarP argsVectorN) (NormalB r) [] + where + e = argsVector + r = InfixE (Just e) (VarE (mkName "asTypeOf")) + (Just $ VarE (mkName "_toArgsBusSizeBitVector") `AppE` resultV) + makeFunc = FunD nameMake + [Clause argPatterns (NormalB resultV) + [resultD, selectorD, argsVectorD + ]] + +generateConMakeMatch dataName args selectorIndex c = + error $ unlines ["Only normal constructors are supported!", "We're given "++show (ppr c)++"."] + +bitVectorSize :: Type -> Type +bitVectorSize a = AppT (ConT $ mkName "BitVectorSize") a +tyBinary f a b = AppT (AppT (ConT $ mkName f) a) b +sizeMax a b = tyBinary "Max" a b +sizeAdd a b = tyBinary "Plus" a b + +argumentsBusSize = mkName "ArgsBusSize" + +data V a = T a | P (V a) (V a) | M (V a) (V a) + deriving (Eq, Show) + +opt :: Eq a => V a -> V a +opt v = snd r + where + r = minimumBy (\a b -> compare (fst a) (fst b)) fixedWeighted + fixed = incrComb [v] + fixedWeighted = map (\v -> (nops v, v)) fixed + incrComb vs + | length vs == length next = vs + | otherwise = incrComb next + where + next = nub $ concatMap comb vs + +{- +t = foldl1 M $ map (foldl1 P) $ map (map T) ts +ts = nub [ + [1,2] -- JALR 1.regv 2.RI + ,[3,1,1,2] -- Ternary 3.TernaryOp 1.regv 1.regv 2.RI + ,[4,1,1] -- Mult 4.Signed 1.regv 1.regv + ,[4,1,1] -- Div 4.Signed 1.regv 1.regv + ,[5,1,2,6] -- Shift 5.ShiftOp 1.regv 2.RI 6.Imm5 + --,[] -- SysCall + ,[7,1,1] -- Trap 7.Cond 1.regv 1.regv + ,[2] -- MFHi 2.RI + ,[2] -- MFLo 2.RI + ,[1] -- JR 1.regv + ,[4,1,1,2] -- SLT 4.Signed 1.regv 1.regv 2.RI + ,[8,1,2,9] -- Imm16Op 8.ImmOp 1.regv 2.RI 9.Imm16 + ,[10,11] -- J 10.Link 11.Imm26 + ,[12,4,1,2,9] -- Load 12.Gran 4.Signed 1.regv 2.RI 9.Imm16 + ,[2,9] -- LUI 2.RI 9.Imm16 + ,[12,1,1,9] -- Store 12.Gran 1.regv 1.regv 9.Imm16 + ,[7,10,1,1,9] -- Branch 7.Cond 10.Link 1.regv 1.regv 9.Imm16 + ] +-} + + +nops (T _) = 1 +nops (P a b) = nops a + nops b + 1 +nops (M a b) = nops a + nops b + 1 + +comb (P a b) = concat [[P x y, P y x] | x <- comb a, y <- comb b] +comb (M a b) + | a == b = comb a +comb (M (P a b) (P c d)) + | a == c = comb $ P a (M b d) +comb (M (P a b) c) + | c == a = comb $ P a b + | c == b = comb $ P a b +comb (M a b) = concat [[M x y, M y x] | x <- comb a, y <- comb b] +comb v = [v] + +opt2 :: Eq a => [[a]] -> V a +opt2 [[a]] = T a +opt2 [as] = foldl1 P $ map T as +opt2 tss = result + where + inc t [] = [(1,t)] + inc t ((c,a):cas) + | t == a = (c+1,a) : cas + | otherwise = (c,a) : inc t cas + mostOccured = snd $ maximumBy (\a b -> compare (fst a) (fst b))$ + foldr inc [] $ concat tss + (withMostOccured', withoutMostOccured) = + partition (mostOccured `elem`) tss + delMostOccured [] = [] + delMostOccured (x:xs) + | x == mostOccured = xs + | otherwise = x : delMostOccured xs + withMostOccured = filter (not . null) $ + map delMostOccured withMostOccured' + left = case withMostOccured of + [] -> T mostOccured + _ -> P (T mostOccured) $ opt2 withMostOccured + right = opt2 withoutMostOccured + result = case withoutMostOccured of + [] -> left + _ -> M left right + + + +generateArgsBusSize :: Name -> [Name] -> [Con] -> Q Dec +generateArgsBusSize dataName argVars conses = do + case interestingConses of + [] -> return () + _ -> do + logGen $ "Starting expression: "++show v + logGen $ "Optimized expression: "++show ov + return result + where + result = TySynInstD argumentsBusSize + [foldl AppT (ConT dataName) (map VarT argVars)] $ + newVariant + newVariant = case interestingConses of + [] -> tySizePure 0 + _ -> fromV ov + oldVariant = + case conArgsSizes of + [] -> tySizePure 0 + cs -> foldl1 (\a b -> sizeMax a b) cs + fromV (T t) = bitVectorSize t + fromV (P a b) = sizeAdd (fromV a) (fromV b) + fromV (M a b) = sizeMax (fromV a) (fromV b) + consesArgs :: [[Type]] + consesArgs = map conArgs conses + conArgs (NormalC _ as) = map snd as + conArgs c = error $ "Unsupported constructor "++show (ppr c) + conArgsSizes = map conArgsSize interestingConses + interestingConses = nub $ filter (not . null) consesArgs + v = foldl1 M $ map (foldl1 P) $ map (map T) interestingConses + ov = + --opt v + opt2 interestingConses + conArgsSize [] = tySizePure 0 + conArgsSize as = foldl1 sizeAdd (map bitVectorSize as) + +selectorBusSizeName = mkName "SelectorBusSize" + +generateSelBusSize :: Name -> [Name] -> [Con] -> Q Dec +generateSelBusSize dataName argVars conses = do + return result + where + result = TySynInstD selectorBusSizeName + [foldl AppT (ConT dataName) (map VarT argVars)] $ + tySizePure (log2 $ length conses) + +log2 0 = 0 +log2 1 = 0 +log2 n = 1 + log2 (div (n+1) 2) + +generateBitRepr :: Name -> [Name] -> [Con] -> Q [Dec] +generateBitRepr dataName argVars conses = return [bitReprInstance, algTypeEncInstance] + where + bitReprName = mkName "BitRepr" + algTypeEncName = mkName "AlgTypeBitEnc" + bitReprInstance = InstanceD context (AppT (ConT bitReprName) dataType) decls + algTypeEncInstance = InstanceD + [ClassP (mkName "Nat") [AppT (ConT $ mkName "ArgsBusSize") dataType]] + (AppT (ConT algTypeEncName) dataType) + [] + dataType = foldl AppT (ConT dataName) (map VarT argVars) + decls = [bitVectorSizeInst, toBitVector, fromBitVector] + context = natHeads++varBitRepr++[algType] + natHeads = map (\t -> ClassP (mkName "Nat") [t]) + [bitVectorSize dataType] --, AppT (ConT $ mkName "ArgsBusSize") dataType] + varBitRepr = map (\v -> ClassP bitReprName [VarT v]) argVars + algType = ClassP algTypeEncName [dataType] + + nx = mkName "x" + vx = VarE nx + toBitVector = FunD (mkName "toBitVector") [Clause [VarP nx] (NormalB toBitVectorCase) []] + toBitVectorCase = CaseE vx $ zipWith toBitVectorConsMatch [0..] conses + nxi = zipWith (\i _ -> mkName $ "x_"++show i) [0..] + nsi = zipWith (\i _ -> mkName $ "s_"++show i) [0..] + pxi = map VarP . nxi + vxi = map VarE . nxi + toBitVectorConsMatch i (NormalC cn as) = Match pattern (NormalB e) [] + where + pattern = AsP (mkName "y") (ConP (mkName $ nameBase cn) (pxi as)) + ci = LitE $ IntegerL (fromIntegral i) + vs = vxi as + argsVector = foldl combine (LitE $ IntegerL 0) vs + combine acc x = r + where + sacc = VarE (mkName "Data.Bits.shiftL") `AppE` acc `AppE` (AppE (VarE $ mkName $ "bitVectorSize") x) + r = InfixE (Just sacc) (VarE $ mkName "Data.Bits..|.") (Just $ VarE (mkName "toBitVector") `AppE` x) + e = (VarE $ mkName "_combineConstructorIndexArgs") `AppE` argsVector `AppE` (VarE (mkName "algTypeArgsBusSize") `AppE` VarE (mkName "y")) `AppE` ci + fromBitVector = FunD (mkName "fromBitVector") [Clause [VarP nx] (NormalB (VarE $ mkName "r")) + [ValD (VarP nr) (NormalB fromBitVectorE) []]] + nr = mkName "r" + vr = VarE $ nr + fromBitVectorConsMatch i (NormalC n as) = + Match (LitP $ IntegerL (fromInteger i)) (NormalB r) decls + where + xs = nxi as + ss = nsi as + decls = snd $ foldl accShift (LitE $ IntegerL 0, []) (zip ss xs) + accShift (p,acc) (s,x) = (VarE s,sdecl:xdecl:acc) + where + xdecl = ValD (VarP x) + (NormalB $ VarE (mkName "fromBitVector") `AppE` (VarE (mkName "Data.Bits.shiftR") `AppE` vx `AppE` p)) + [] + sdecl = ValD (VarP s) + (NormalB $ InfixE (Just p) (VarE $ mkName "+") (Just $ VarE (mkName "bitVectorSize") `AppE` VarE x)) + [] + r = foldr (flip AppE) (ConE $ mkName $ nameBase n) (map VarE xs) + fromBitVectorE = CaseE sel $ zipWith fromBitVectorConsMatch [0..] conses + where + sel = InfixE (Just shifted) (VarE $ mkName "Data.Bits..&.") (Just $ VarE (mkName "algTypeSelectorBusMask") `AppE` vr) + shifted = (VarE $ mkName "Data.Bits.shiftR") `AppE` vx `AppE` (VarE (mkName "algTypeArgsBusSize") `AppE` vr) + bitVectorSizeInst = TySynInstD (mkName "BitVectorSize") [dataType] + (sizeAdd (AppT (ConT selectorBusSizeName) dataType) + (AppT (ConT argumentsBusSize) dataType)) diff --git a/src/Hardware/HHDL/ToWires.hs b/src/Hardware/HHDL/ToWires.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/ToWires.hs @@ -0,0 +1,113 @@ +-- |ToWires.hs +-- +-- A class that converts between Haskell types and bit vectors (Integer) +-- with instance for some handy types. +-- +-- Copyright (C) Serguey Zefirov, 2009 + +{-# LANGUAGE TypeOperators, TemplateHaskell, TypeFamilies, FlexibleContexts, UndecidableInstances #-} + +module Hardware.HHDL.ToWires where + +import Data.Bits +import Data.Word + +import Hardware.HHDL.TyLeA + +class Nat (BusSize a) => ToWires a where + type BusSize a + wireSizeType :: a -> BusSize a + wireSizeType _ = undefined + wireSize :: a -> Int + wireSize x = fromNat $ wireSizeType x + wireMul :: a -> Integer + wireMul x = Data.Bits.shiftL 1 (wireSize x) + wireSelSize :: a -> Int + wireSelSize = const 0 + -- Integer should occupy no more than wireSize bits, higher ones should be 0 + toWires :: a -> Integer + -- fromWires should work with integers that have non-zero bits + -- above wireSize index. + fromWires :: Integer -> a + -- enumeration size. + -- valuesCount of (Maybe a) returns 1+valuesCount (x::a) + -- valuesCount of Either a b returns valuesCount (x::a) + valuesCount (yLLb) + -- valuesCount of (a,b) returns valuesCoutn (x::a) * valuesCount (y::b) +-- valuesCount :: a -> Integer +-- -- valueIndex. +-- -- get a value and return an index inside enumeration. +-- valueIndex :: a -> Integer + -- enumerate values. +-- enumerate :: [a] + +castWires :: (ToWires a, ToWires b, BusSize a ~ BusSize b) => a -> b +castWires from = to + where + to = fromWires $ toWires from + +infixr 5 :&: -- just like (:) +data l :&: r = l :&: r +instance (Nat (Plus (BusSize l) (BusSize r)), ToWires l, ToWires r) => ToWires (l :&: r) where + type BusSize (l :&: r) = Plus (BusSize l) (BusSize r) + toWires (a :&: b) = Data.Bits.shiftL (toWires a) (wireSize b) .|. toWires b + fromWires x = a :&: b + where + b = fromWires x + a = fromWires $ Data.Bits.shiftR x (wireSize b) +-- enumerate = [a :&: b | a <- enumerate, b <- enumerate] +-- valuesCount (a :&: b) = valuesCount a * valuesCount b + +infixr 4 :|: -- allows us to write a :&: b :|: c :&: d which equal to (a :&: b) :|: (c :&: d) +data l :|: r = l :|: r +instance (Nat (Max (BusSize l) (BusSize r)), ToWires l, ToWires r) => ToWires (l :|: r) where + type BusSize (l :|: r) = Max (BusSize l) (BusSize r) + toWires (a :|: b) = toWires a .|. toWires b + fromWires x = a :|: b + where + b = fromWires x + a = fromWires x +-- enumerate = error "no enumeration for :|:" + -- [a :|: b | a <- enumerate, b <- enumerate] +-- valuesCount (a :|: b) = max (valuesCount a) (valuesCount b) + +instance ToWires Int where + type BusSize Int = $(tySize 32) + toWires n = fromIntegral n .&. 0xffffffff + fromWires x = fromIntegral x .&. 0xffffffff +-- valuesCount = const (Data.Bits.shiftL (1::Integer) 32) +-- valueIndex = fromIntegral +-- enumerate = [fromIntegral n | n <- [0..0xffffffff]] + +instance ToWires Word32 where + type BusSize Word32 = $(tySize 32) + toWires n = fromIntegral n .&. 0xffffffff + fromWires x = fromIntegral x .&. 0xffffffff +-- valuesCount = const (Data.Bits.shiftL (1::Integer) 32) +-- valueIndex = fromIntegral +-- enumerate = [fromIntegral n | n <- [0..0xffffffff]] + +instance ToWires Word16 where + type BusSize Word16 = $(tySize 16) + toWires n = fromIntegral n .&. 0xffff + fromWires x = fromIntegral x .&. 0xffff +-- valuesCount = const (Data.Bits.shiftL (1::Integer) 32) +-- valueIndex = fromIntegral +-- enumerate = [fromIntegral n | n <- [0..0xffffffff]] + +instance ToWires Word8 where + type BusSize Word8 = $(tySize 8) + toWires n = fromIntegral n .&. 0xff + fromWires x = fromIntegral x .&. 0xff +-- valuesCount = const (Data.Bits.shiftL (1::Integer) 32) +-- valueIndex = fromIntegral +-- enumerate = [fromIntegral n | n <- [0..0xffffffff]] + +instance ToWires () where + type BusSize () = $(tySize 0) + toWires _ = 0 + fromWires _ = () +-- valuesCount = const 1 +-- valueIndex = fromIntegral +-- enumerate = [()] + + diff --git a/src/Hardware/HHDL/TyLeA.hs b/src/Hardware/HHDL/TyLeA.hs new file mode 100644 --- /dev/null +++ b/src/Hardware/HHDL/TyLeA.hs @@ -0,0 +1,245 @@ +-- |TyLeA.hs +-- +-- Type level decimal arithmetic. +-- +-- Decimal numbers represented either by standalone digits (Dx) +-- or by lists of standalone digits (D1 :. D2 :. D8), (D2 :. D4). +-- +-- Author: Serguey Zefirov, 2011 +-- +-- I place it into public domain. + +{-# LANGUAGE TypeFamilies, TemplateHaskell, TypeOperators, UndecidableInstances #-} + +module Hardware.HHDL.TyLeA( + -- how to convert from types to runtime values. + Nat(fromNat) + -- numbers construction. + -- numbers are either single digits or digits, separated by ":." operator. + , D0, D1, D2, D3, D4 + , D5, D6, D7, D8, D9 + , (:*)(..) + -- functions. + , Max, Plus + , Mul, Div2, Log2 + -- shortcuts. + , tySizePure + , tySize -- use it as SomeSizedType $(tySize 1024) (equal to D1 :* D0 :* D2 :* D4) +) where + +import Control.Monad +import Language.Haskell.TH + +data D0 = D0 +data D1 = D1 +data D2 = D2 +data D3 = D3 +data D4 = D4 +data D5 = D5 +data D6 = D6 +data D7 = D7 +data D8 = D8 +data D9 = D9 + +infixl 5 :* +data ds :* d = ds :* d deriving Show + +------------------------------------------------------------------------------- +-- Maximum. + +data Equal = Equal deriving Show +data Less = Less deriving Show +data Greater = Greater deriving Show + +class Mat a where mat :: a +instance Mat Equal where mat = Equal +instance Mat Less where mat = Less +instance Mat Greater where mat = Greater + +type family Max a b +type instance Max a b = SelectMax (Compare a b Equal) a b + +type family SelectMax what a b +type instance SelectMax Equal a b = a +type instance SelectMax Less a b = b +type instance SelectMax Greater a b = a + +type family Compare a b prevCond +$(liftM concat $ forM [(a,b) | a <- [0..9], b <- [0..9]] $ \(a,b) -> do + let compareName = mkName "Compare" + let digit n = ConT $ mkName $ "D"++show n + let prevCond = VarT $ mkName "prevCond" + let less = ConT $ mkName "Less" + let greater = ConT $ mkName "Greater" + let da = digit a + let db = digit b + let compareDigits = TySynInstD compareName [da, db,prevCond] $ case compare a b of + EQ -> prevCond + LT -> less + GT -> greater + let va = VarT $ mkName "a" + let vb = VarT $ mkName "b" + let vc = VarT $ mkName "c" + let number h l = AppT (AppT (ConT $ mkName ":*") h) l + let compareNumberRight = TySynInstD compareName [da, number vb db, prevCond] less + let compareNumberLeft = TySynInstD compareName [number va da, db, prevCond] greater + let compareNumbers = TySynInstD compareName [number va da, number vb db, prevCond] $ case compare a b of + EQ -> ConT compareName `AppT` va `AppT` vb `AppT` prevCond + LT -> ConT compareName `AppT` va `AppT` vb `AppT` less + GT -> ConT compareName `AppT` va `AppT` vb `AppT` greater + let r = [compareDigits, compareNumberLeft, compareNumberRight, compareNumbers] +-- runIO $ mapM (putStrLn . show . ppr) r + return r + ) + +------------------------------------------------------------------------------- +-- Addition. + +type family Sum3 a b c +$(liftM concat $ forM [(a,b,c) | a <- [0..9], b <- [0..9], c <- [0..1]] $ \(a,b,c) -> do + let sum3Name = mkName "Sum3" + let sum = a+b+c + let s = sum `mod` 10 + let propC = sum `div` 10 + let digit n = ConT $ mkName $ "D"++show n + let number h l = AppT (AppT (ConT $ mkName ":*") h) l + let ds = digit s + let digitSumResult + | propC == 0 = ds + | otherwise = number (digit propC) (ds) + let da = digit a + let db = digit b + let dc = digit c + let dPropC = digit propC + let va = VarT $ mkName "a" + let vb = VarT $ mkName "b" + let vc = VarT $ mkName "c" + let digitSum = TySynInstD sum3Name [da, db, dc] digitSumResult + let numberSumResult = number (ConT sum3Name `AppT` va `AppT` vb `AppT` dPropC) ds + let numberSum = TySynInstD sum3Name [number va da, number vb db, dc] numberSumResult + let add3 a b c = ConT sum3Name `AppT` a `AppT` b `AppT` c + let partLeftSumResult + | propC == 0 = number va ds + | otherwise = number (add3 va (digit 0) (digit 1)) ds + let partLeft = TySynInstD sum3Name [number va da, db, dc] partLeftSumResult + let partRightSumResult + | propC == 0 = number vb ds + | otherwise = number (add3 (digit 0) vb (digit 1)) ds + let partRight = TySynInstD sum3Name [da, number vb db, dc] partRightSumResult + let r = [digitSum, numberSum, partLeft, partRight] +-- runIO $ mapM (putStrLn . show . ppr) r + return r + ) + +type family Plus a b +type instance Plus a b = Sum3 a b D0 + +------------------------------------------------------------------------------- +-- Multiplication. + +type family Mul a b +type instance Mul a b = MulAcc D0 a b + +type family Dup a +type instance Dup a = Plus a a + +type family MulAcc acc a b +type instance MulAcc acc a D0 = acc +type instance MulAcc acc a D1 = Plus acc a +type instance MulAcc acc a D2 = Plus acc (Dup a) +type instance MulAcc acc a D3 = Plus acc (Plus a (Dup a)) +type instance MulAcc acc a D4 = Plus acc (Dup (Dup a)) +type instance MulAcc acc a D5 = Plus acc (Plus (Dup (Dup a)) a) +type instance MulAcc acc a D6 = Plus acc (Dup (Plus (Dup a) a)) +type instance MulAcc acc a D7 = Plus acc (Plus (Dup (Plus (Dup a) a)) a) +type instance MulAcc acc a D8 = Plus acc (Dup (Dup (Dup a))) +type instance MulAcc acc a D9 = Plus acc (Plus (Dup (Dup (Dup a))) a) +type instance MulAcc acc a (bs :* b) = MulAcc (Mul a bs :* D0) a b + + +------------------------------------------------------------------------------- +-- Division by 2. + +type family Div2 a +type instance Div2 D0 = D0 +type instance Div2 D1 = D0 +type instance Div2 D2 = D1 +type instance Div2 D3 = D1 +type instance Div2 D4 = D2 +type instance Div2 D5 = D2 +type instance Div2 D6 = D3 +type instance Div2 D7 = D3 +type instance Div2 D8 = D4 +type instance Div2 D9 = D4 +type instance Div2 (D0 :* a) = Div2 a +type instance Div2 (D1 :* a) = Plus (Div2 a) D5 +type instance Div2 (D2 :* a) = D1 :* Div2 a +type instance Div2 (D3 :* a) = D1 :* Plus (Div2 a) D5 +type instance Div2 (D4 :* a) = D2 :* Div2 a +type instance Div2 (D5 :* a) = D2 :* Plus (Div2 a) D5 +type instance Div2 (D6 :* a) = D3 :* Div2 a +type instance Div2 (D7 :* a) = D3 :* Plus (Div2 a) D5 +type instance Div2 (D8 :* a) = D4 :* Div2 a +type instance Div2 (D9 :* a) = D4 :* Plus (Div2 a) D5 +type instance Div2 (as :* D0 :* a) = Div2 (as :* D0) :* Div2 a +type instance Div2 (as :* D1 :* a) = Div2 (as :* D0) :* Plus (Div2 a) D5 +type instance Div2 (as :* D2 :* a) = Div2 (as :* D2) :* Div2 a +type instance Div2 (as :* D3 :* a) = Div2 (as :* D2) :* Plus (Div2 a) D5 +type instance Div2 (as :* D4 :* a) = Div2 (as :* D4) :* Div2 a +type instance Div2 (as :* D5 :* a) = Div2 (as :* D4) :* Plus (Div2 a) D5 +type instance Div2 (as :* D6 :* a) = Div2 (as :* D6) :* Div2 a +type instance Div2 (as :* D7 :* a) = Div2 (as :* D6) :* Plus (Div2 a) D5 +type instance Div2 (as :* D8 :* a) = Div2 (as :* D8) :* Div2 a +type instance Div2 (as :* D9 :* a) = Div2 (as :* D8) :* Plus (Div2 a) D5 + +------------------------------------------------------------------------------- +-- Base 2 logarithm. + +type family Log2 a +type instance Log2 D0 = D0 +type instance Log2 D1 = D0 +type instance Log2 D2 = D1 +type instance Log2 D3 = D2 +type instance Log2 D4 = D2 +type instance Log2 D5 = D3 +type instance Log2 D6 = D3 +type instance Log2 D7 = D3 +type instance Log2 D8 = D3 +type instance Log2 D9 = D4 +type instance Log2 (as :* a) = Inc (Log2 (Div2 (Inc (as :* a)))) + +type family Inc a +type instance Inc a = Plus a D1 + +------------------------------------------------------------------------------- +-- Conversion to runtime values. + +class Nat a where + fromNat :: a -> Int + natMult :: a -> Int + natMult = const 0 + +instance Nat D0 where { fromNat = const 0; natMult = const 1} +instance Nat D1 where { fromNat = const 1; natMult = const 1} +instance Nat D2 where { fromNat = const 2; natMult = const 1} +instance Nat D3 where { fromNat = const 3; natMult = const 1} +instance Nat D4 where { fromNat = const 4; natMult = const 1} +instance Nat D5 where { fromNat = const 5; natMult = const 1} +instance Nat D6 where { fromNat = const 6; natMult = const 1} +instance Nat D7 where { fromNat = const 7; natMult = const 1} +instance Nat D8 where { fromNat = const 8; natMult = const 1} +instance Nat D9 where { fromNat = const 9; natMult = const 1} + +instance (Nat ds, Nat d) => Nat (ds :* d) where + fromNat ~(ds :* d) = fromNat d + fromNat ds * 10 + natMult = const 1 + +tySizePure :: Int -> Type +tySizePure n = f $ show n + where + f [c] = digit c + f (c:cs) = AppT (AppT (ConT $ mkName ":*") $ digit c) $ f cs + digit c = ConT $ mkName $ ['D',c] + +tySize :: Int -> Q Type +tySize = return . tySizePure