Wired (empty) → 0.1
raw patch · 27 files changed
+3536/−0 lines, 27 filesdep +QuickCheckdep +basedep +chalmers-lava2000setup-changed
Dependencies added: QuickCheck, base, chalmers-lava2000, containers, mtl
Files
- Analysis/STA.hs +96/−0
- Data/Hardware.hs +21/−0
- Data/Hardware/Internal.hs +329/−0
- Data/Logical/Knot.hs +88/−0
- Data/Logical/Let.hs +100/−0
- Examples/Mult.hs +302/−0
- Examples/Sklansky.hs +29/−0
- Examples/UsingLava.hs +74/−0
- Examples/UsingWired.hs +58/−0
- LICENSE +31/−0
- Lava.hs +34/−0
- Lava/Internal.hs +152/−0
- Lava/Interpret.hs +122/−0
- Lava/Loop.hs +88/−0
- Lava/Model.hs +259/−0
- Lava/Patterns.hs +138/−0
- Lava/Port.hs +193/−0
- Layout.hs +32/−0
- Layout/Floorplan.hs +287/−0
- Layout/Internal.hs +173/−0
- Layout/Postscript.hs +404/−0
- Libs/Simple130nm/Lava.hs +133/−0
- Libs/Simple130nm/Wired.hs +96/−0
- Setup.lhs +3/−0
- Wired.cabal +64/−0
- Wired.hs +19/−0
- Wired/Model.hs +211/−0
+ Analysis/STA.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Analysis.STA+ ( TransitionTime+ , Timing (..)+ , STALibrary+ , Prop+ , analyzeTiming+ ) where++++import Control.Arrow ((***))+import Control.Monad++import Data.Hardware+import Lava.Internal+import Analysis.STA.Library++++data Prop = Prop+ { riseTiming :: Timing+ , fallTiming :: Timing+ , capacitance :: Capacitance+ }++++addTiming :: Timing -> Timing -> Timing+addTiming (Timing ar1 tr1) (Timing ar2 tr2) = Timing (ar1+ar2) (tr1+tr2)++addProp :: Prop -> Prop -> Prop+addProp (Prop timR1 timF1 cap1) (Prop timR2 timF2 cap2) =+ Prop (addTiming timR1 timR2) (addTiming timF1 timF2) (cap1+cap2)++timing0 = Timing 0 0++prop0 = Prop timing0 timing0 0++propCap cap = prop0 {capacitance = cap}++propRiseFall timR timF = prop0 {riseTiming = timR, fallTiming = timF}++getDelay :: Prop -> Delay+getDelay (Prop timR timF _) = maxArrival timR timF++++interpTiming :: STALibrary lib => Interpretation lib Prop+interpTiming = Interp+ { defaultVal = prop0+ , accumulator = addProp+ , propagator = propagate+ }+ where+ propagate cell ss = outs' ++ ins'+ where+ no = numOuts cell+ (outs,ins) = splitAt no ss++ propagatePath oPin oCap (iPin, Prop iTimR iTimF _) = (oTimR,oTimF)+ where+ oTimR = maximumByArrival+ [ delay cell iPin oPin Rising oCap iTimR+ , delay cell iPin oPin Rising oCap iTimF+ ]++ oTimF = maximumByArrival+ [ delay cell iPin oPin Falling oCap iTimF+ , delay cell iPin oPin Falling oCap iTimR+ ]++ ins' = map (Just . propCap) (loadCaps cell)++ outs' = do+ (oPin, Prop _ _ oCap) <- zip [0..] outs+ let (timRs,timFs) =+ unzip $ map (propagatePath oPin oCap) $ zip [icast no ..] ins+ return $ Just $ propRiseFall+ (maximumByArrival timRs)+ (maximumByArrival timFs)++++analyzeTiming+ :: ( STALibrary lib+ , PortStruct ps Signal t+ , PortStruct pd Delay t+ )+ => Lava lib ps -> (pd, InterpDesignDB lib Prop)++analyzeTiming = (unport . fmap getDelay *** id) . interpret_ interpTiming [] . liftM port+ -- *** Check for loop.+ -- *** Add wire loads.+
+ Data/Hardware.hs view
@@ -0,0 +1,21 @@+module Data.Hardware+ ( Name+ , Tag+ , IntCast (..)+ , DoubleCast (..)+ , icast+ , dcast+ , Length+ , Width+ , Height+ , Layer+ , Capacitance+ , Resistance+ , Time+ , Delay+ ) where++++import Data.Hardware.Internal+
+ Data/Hardware/Internal.hs view
@@ -0,0 +1,329 @@+module Data.Hardware.Internal where++++import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.String+import Test.QuickCheck++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++data TypeOf a = T+ -- Used to pass a type constraint to an overloaded function. This is safer+ -- than using undefined.++typeOf :: a -> TypeOf a+typeOf = const T++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++instance IsString ShowS+ where+ fromString = showString++(.+) :: ShowS -> ShowS -> ShowS+(.+) = (.)+ -- Works better than (.) with overloaded string literals.++infixr 9 .+++unwordS :: [ShowS] -> ShowS+unwordS [] = id+unwordS [s] = s+unwordS (s:ss) = s .+ " " .+ unwordS ss++unlineS :: [ShowS] -> ShowS+unlineS [] = id+unlineS [s] = s+unlineS (s:ss) = s . "\n" . unlineS ss++++newtype Name = Name {unName :: String}+ deriving (Eq, Ord, IsString)++newtype Tag = Tag {unTag :: String}+ deriving (Eq, Ord, IsString)++instance Show Name+ where+ show = unName++instance Show Tag+ where+ show = unTag++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++class Num n => IntCast n+ where+ toInt :: n -> Int+ fromInt :: Int -> n++instance IntCast Int+ where+ toInt = id+ fromInt = id++instance IntCast Double+ where+ toInt = round+ fromInt = fromIntegral++++class Num n => DoubleCast n+ where+ toDouble :: n -> Double+ fromDouble :: Double -> n++instance DoubleCast Double+ where+ toDouble = id+ fromDouble = id++instance DoubleCast Int+ where+ toDouble = fromIntegral+ fromDouble = round++instance DoubleCast Rational+ where+ toDouble = fromRational+ fromDouble = toRational++icast :: (IntCast m, IntCast n) => m -> n+icast = fromInt . toInt+ -- Conversion between different integer types++dcast :: (DoubleCast m, DoubleCast n) => m -> n+dcast = fromDouble . toDouble+ -- Conversion between different floting point types++++class Multiply n1 n2 n3 | n1 n2 -> n3, n1 n3 -> n2, n2 n3 -> n1+ where+ (><) :: n1 -> n2 -> n3++instance DoubleCast n => Multiply Double n n+ where+ d >< n = dcast d * n++instance DoubleCast n => Multiply n Double n+ where+ n >< d = n * dcast d++++newtype Pin = Pin Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- Identifies a pin of a cell.++newtype ConstId = ConstId Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- Identifies a constant signal.++newtype PrimInpId = PrimInpId Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- Identifies a primary input signal.++newtype CellId = CellId Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- Identifies a cell.++++newtype Length = Length Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- [nm]++newtype Width = Width Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- [nm]++newtype Height = Height Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)+ -- [nm]++++newtype Layer = Layer Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)++++newtype Capacitance = Cap Double+ deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)+ -- [F]++newtype Resistance = Res Double+ deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)+ -- [Ω]++newtype Time = Time Double+ deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)+ -- [s]++type Delay = Time++instance Multiply Resistance Capacitance Time+ where+ r >< c = dcast (r * dcast c)++instance Multiply Capacitance Resistance Time+ where+ c >< r = r >< c++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++type Position = (Width,Height)+type Size = (Width,Height)++++data Angle = Horizontal | Vertical+ deriving (Eq, Show)++data Direction = Rightwards | Leftwards | Upwards | Downwards+ deriving (Eq, Show)++type Orientation = (Bool, Direction)+ -- The bool tells whether or not the object is flipped around the y-axis.++++directionAngle :: Direction -> Angle+directionAngle Rightwards = Horizontal+directionAngle Leftwards = Horizontal+directionAngle _ = Vertical++north :: Orientation+north = (False,Upwards)+ -- This is taken as the standard orientation.++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++totalLookup :: Ord k => k -> Map k [a] -> [a]+totalLookup k = concat . maybeToList . Map.lookup k+ -- A lookup function that is defined for all keys.++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++spanning ::+ ((Position,Position) -> Double) -> [Position] -> [(Position,Position)]++spanning _ [] = []+spanning dist (p:ps) = span ps [p] []+ where+ span [] _ ls = ls+ span ps qs ls = span (delete p ps) (p:qs) ((p,q):ls)+ where+ (p,q) = minimumBy (compare `on` dist) [ (p,q) | p <- ps, q <- qs ]++ -- Computes the minimal spanning tree based on the given distance function.+ -- *** Comlexity: O(n²)++++euclidDistance :: (Position,Position) -> Double+euclidDistance ((x1,y1),(x2,y2)) =+ sqrt $ fromIntegral $ (x1-x2)^2 + icast ((y1-y2)^2)++rectiDistance :: (Position,Position) -> Double+rectiDistance ((x1,y1),(x2,y2)) = icast (abs (x1-x2)) + icast (abs (y1-y2))++euclidSpanning :: [Position] -> [(Position,Position)]+euclidSpanning = spanning euclidDistance++rectiSpanning :: [Position] -> [(Position,Position)]+rectiSpanning = spanning rectiDistance++++deriving instance Arbitrary Width+deriving instance Arbitrary Height++++prop_span1 dist ps =+ length ps > 0 ==> length (spanning dist ps) == (length ps - 1)++prop_span2 dist ps = ps == nub ps ==> ls == nub ls+ where+ ls = spanning dist ps+ -- No duplicates in input means no dups. in output++prop_span3 dist ps = length ps > 1 ==> sort (nub ps) == sort (nub qs)+ where+ qs = concat [ [p,q] | (p,q) <- spanning dist ps ]+ -- The set of points is unchanged++prop_span4 dist ps = sum (map dist ls) <= sum (map dist ls')+ where+ ls = spanning dist ps+ ls' = [ (p1,p2) | p1 <- ps, p2 <- ps ] -- The complete graph++prop_span5 dist ps = sum (map dist ls) ~= sum (map dist ls')+ where+ a ~= b = abs (a-b) < 0.01++ ls = spanning dist ps+ ls' = spanning dist (reverse ps)+ -- Sanity check++++checkAll = do+ quickCheck $ prop_span1 euclidDistance+ quickCheck $ prop_span2 euclidDistance+ quickCheck $ prop_span3 euclidDistance+ quickCheck $ prop_span4 euclidDistance+ quickCheck $ prop_span5 euclidDistance++ quickCheck $ prop_span1 rectiDistance+ quickCheck $ prop_span2 rectiDistance+ quickCheck $ prop_span3 rectiDistance+ quickCheck $ prop_span4 rectiDistance+ quickCheck $ prop_span5 rectiDistance+
+ Data/Logical/Knot.hs view
@@ -0,0 +1,88 @@+module Data.Logical.Knot+ ( Knot+ , KnotT+ , MonadKnot+ , askKnot+ , askKnotDef+ , (*=)+ , accKnot+ , tieKnot+ , accKnotT+ , tieKnotT+ ) where++++import Data.Map (Map,fromList,fromListWith,(!),findWithDefault)+import Control.Monad.Reader+import Control.Monad.Writer++++type Constraint i x = (i,x)+type Solution i x = Map i x++newtype Knot i x a =+ Knot (ReaderT (Solution i x) (Writer [Constraint i x]) a)+ deriving (Monad, MonadFix)++newtype KnotT i x m a =+ KnotT (ReaderT (Solution i x) (WriterT [Constraint i x] m) a)+ deriving (Monad, MonadFix)++++instance MonadTrans (KnotT i x)+ where+ lift = KnotT . lift . lift+ -- Couldn't be derived for some reason++++class (Monad m, Ord i) => MonadKnot i x m | m -> i x+ where+ askKnot :: i -> m x+ askKnotDef :: x -> i -> m x++ (*=) :: i -> x -> m ()++++instance Ord i => MonadKnot i x (Knot i x)+ where+ askKnot i = Knot $ asks (! i)+ askKnotDef def i = Knot $ asks $ findWithDefault def i++ i *= x = Knot $ tell [(i,x)]++instance (Monad m, Ord i) => MonadKnot i x (KnotT i x m)+ where+ askKnot i = KnotT $ asks (! i)+ askKnotDef def i = KnotT $ asks $ findWithDefault def i++ i *= x = KnotT $ tell [(i,x)]++++accKnot :: Ord i => (x -> x -> x) -> Knot i x a -> (a, Map i x)+accKnot acc (Knot knot) = (a,solution)+ where+ (a,ass) = runWriter $ runReaderT knot solution+ solution = fromListWith acc ass+ -- acc should be commutative and associative.++tieKnot :: Ord i => Knot i x a -> (a, Map i x)+tieKnot = accKnot (error "tieKnot: Over-constrained")++accKnotT+ :: (Ord i, MonadFix m)+ => (x -> x -> x) -> KnotT i x m a -> m (a, Map i x)+accKnotT acc (KnotT knot) = mdo+ (a,ass) <- runWriterT $ runReaderT knot solution+ let solution = fromListWith acc ass+ return (a,solution)+ -- acc should be commutative and associative.++tieKnotT :: (Ord i, MonadFix m) => KnotT i x m a -> m (a, Map i x)+tieKnotT = accKnotT (error "tieKnot: Over-constrained")+
+ Data/Logical/Let.hs view
@@ -0,0 +1,100 @@+module Data.Logical.Let+ ( Let+ , LetT+ , Var+ , MonadLet+ , free+ , val+ , (===)+ , runLet+ , runLetT+ ) where++++import Data.Map (Map)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer++import Data.Logical.Knot++++type VarId = Integer++newtype Let x a = Let (StateT VarId (Knot VarId x) a)+ deriving (Monad, MonadFix, MonadKnot VarId x)++newtype LetT x m a = LetT (StateT VarId (KnotT VarId x m) a)+ deriving (Monad, MonadFix, MonadKnot VarId x)++data Var x = Var VarId x++++instance MonadTrans (LetT x)+ where+ lift = LetT . lift . lift+ -- Couldn't be derived for some reason++instance MonadKnot i x m => MonadKnot i x (StateT s m)+ where+ askKnot = lift . askKnot+ askKnotDef x = lift . askKnotDef x+ i *= x = lift (i *= x)+ -- So that MonadKnot can be derived for Let and LetT.++++free_ :: MonadKnot VarId x m => StateT VarId m (Var x)+free_ = do+ vid <- get+ put (succ vid)+ x <- lift $ askKnot vid+ return (Var vid x)++class MonadKnot VarId x m => MonadLet x m | m -> x+ where+ free :: m (Var x)++instance MonadLet x (Let x)+ where+ free = Let free_++instance Monad m => MonadLet x (LetT x m)+ where+ free = LetT free_++++val :: Var x -> x+val (Var _ x) = x++infix 1 ===++(===) :: MonadLet x m => Var x -> x -> m ()+Var vid _ === x = vid *= x++var :: MonadLet x m => x -> m (Var x)+var x = do+ v <- free+ v === x+ return v+++test = runLet $ do+ a' <- var a+ a' === a+ return a+ where+ a = 4 :: Int++acc = error "Multiple assignments to variable"++runLet :: Let x a -> a+runLet (Let ma) = fst $ fst $ accKnot acc $ runStateT ma 0++runLetT :: MonadFix m => LetT x m a -> m a+runLetT (LetT ma) = liftM (fst.fst) $ accKnotT acc $ runStateT ma 0+
+ Examples/Mult.hs view
@@ -0,0 +1,302 @@+-- An implementation of a "block view" of Mary's FMCAD'04 multiplier. This+-- version improves Mary's by making sure there is at most one half adder per+-- column. The recursion in compressBlock is different in that it works from the+-- bottom. This allows the blocks to be chosen more greedily, and this will+-- supposedly be easier to extend to a description with 5:3-compressors (or+-- higher).+--+-- Another advantage is that (even though the code is bigger) it is easier to+-- understand the recursion. The following pictures explain the different steps:+--+-- Carry signals left:+--+-- x+1 x x-1+-- ,---, ,---, ,---,+-- --| F |-- --| H |-- --| W |+-- '---' '---' '---'+-- x x x+--+-- No carry signals left:+--+-- x+2 x+1+-- ,---, ,---,+-- | F |-- | H |--+-- '---' '---'+-- x x+--+-- compressY uses the steps in the upper picture until there are no carry+-- signals left (and this is bound to happen since each step removes one carry).+-- Then compressNoY uses the lower picture to compress all remaining x signals.++++import Data.List hiding (insert)+import Control.Monad+import Test.QuickCheck+import System.Random++import Wired+import Libs.Simple130nm.Wired++++data Block = W | H | F+ deriving (Eq,Ord,Show)++++smallNat :: (Random n, Integral n) => Gen n+smallNat = sized $ \n -> choose (0, fromIntegral n)++smallPos :: (Random n, Integral n) => Gen n+smallPos = sized $ \n -> choose (1, fromIntegral n + 1)++partProds :: Gen [Int]+partProds = sized $ \n -> do+ m <- smallPos+ replicateM m smallPos++count :: Eq a => a -> [a] -> Int+count a = length . filter (==a)++maxSum :: Num a => [a] -> a+maxSum xs+ = sum+ $ map (uncurry (*))+ $ zip xs (map product $ inits $ repeat 2)+ -- The biggest number the part. prods. can sum up to++bits :: (Integral b, Integral a) => a -> b+bits n = ceiling (log (fromIntegral (n+1)) / log 2)+ -- Number of bits needed to represent n++++compressBlock :: Int -> Int -> ([Block], Int)++compressBlock xTot yTot++ | xTot<=1 && yTot==0 = ([],0)+ | xTot==0 && yTot==1 = ([W],0)+ -- Cases with <= 1 signal out++ | otherwise = (reverse col, y')++ where+ (col,y') = compressY 2 yTot++ compressY x 0 = compressNoY x+ compressY x y+ | diff == 0 = (W:col1, y1)+ | diff == 1 = (H:col2, y2+1)+ | diff >= 2 = (F:col3, y3+1)+ where+ diff = y+xTot-x++ (col1,y1) = compressY (x-1) (y-1)+ (col2,y2) = compressY x (y-1)+ (col3,y3) = compressY (x+1) (y-1)++ compressNoY x+ | diff == 0 = ([],0)+ | diff == 1 = (H:col1, y1+1)+ | diff >= 2 = (F:col2, y2+1)+ where+ diff = xTot-x++ (col1,y1) = compressNoY (x+1)+ (col2,y2) = compressNoY (x+2)++++prop_compressBlock1 = forAll smallNat $ \x -> forAll smallNat $ \y ->+ let blocks = fst $ compressBlock x y+ in blocks == sort blocks+ -- Blocks are ordered.++prop_compressBlock2 = forAll smallNat $ \x -> forAll smallNat $ \y ->+ let blocks = fst $ compressBlock x y+ in count H blocks <= 1+ -- There is at most one H in a column.++prop_compressBlock3 = forAll smallNat $ \x -> forAll smallNat $ \y ->+ let (blocks,y') = compressBlock x y+ in length blocks == max y y'+ -- The number of blocks in the column is equal to the maximum number of carry+ -- signals going in or out.++prop_compressBlock4 = forAll smallNat $ \x -> forAll smallNat $ \y ->+ let (blocks,yOut) = compressBlock x y+ removed = count F blocks+ in x+y>=2 ==> removed == (x+y) - (2+yOut)+ -- The number of removed (compressed) bits is equal to the difference between+ -- #signals in and #signals out.++++redArrayBlock :: [Int] -> [[Block]]+redArrayBlock xs = red xs 0+ where+ red [] 0 = []++ red [] y = blocks : red [] yOut+ where+ (blocks,yOut) = compressBlock 0 y++ red (x:xs) y = blocks : red xs yOut+ where+ (blocks,yOut) = compressBlock x y++++prop_redArrayBlock1 = forAll partProds $ \xs ->+ let w = length xs+ h = maximum xs+ wOut = length $ redArrayBlock xs+ in wOut <= w+h-1++prop_redArrayBlock2 = forAll partProds $ \xs ->+ let w = length xs+ wOut = length $ redArrayBlock xs+ in wOut >= w++prop_redArrayBlock3 = forAll partProds $ \xs ->+ let bss = redArrayBlock xs+ removed = sum $ map (count F) bss+ remains = sum xs - removed+ in remains >= length bss && remains <= 2 * length bss+ -- The number of removed (compressed) bits is equal to the difference between+ -- #signals in and #signals out. It's hard to determine the #signals out,+ -- because some columns may only have one bit out. Therefore we just check the+ -- interval.++prop_redArrayBlock4 = forAll partProds $ \xs ->+ let wOut = length $ redArrayBlock xs+ s = maxSum $ map fromIntegral xs+ in bits s `elem` [wOut, wOut+1]+ -- The number of bits needed to count all inputs (times signigicance) is equal+ -- to, or one more than the number of columns (final adder might add one bit).++++checkAll = do+ quickCheck prop_compressBlock1+ quickCheck prop_compressBlock2+ quickCheck prop_compressBlock3+ quickCheck prop_compressBlock4+ quickCheck prop_redArrayBlock1+ quickCheck prop_redArrayBlock2+ quickCheck prop_redArrayBlock3+ quickCheck prop_redArrayBlock4++++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++++type CircBlock =+ (Maybe Signal, [Signal]) -> Wired Simple130nm ([Signal], Maybe Signal)++insert a bs = bs ++ [a]++bus ps = rotate 1 $ space 500 () >> guideE 1 600 ps++++c22 :: CircBlock++c22 (Nothing, ps@(_:_:_)) = do+ p1:p2:ps' <- bus ps+ (s,c) <- flipX $ halfAdd (p1,p2)+ return (insert s ps', Just c)++c22 (Just c, ps@(_:_)) = do+ ps' <- bus ps+ let p1:p2:ps'' = insert c ps'+ (s,c') <- flipX $ halfAdd (p1,p2)+ return (insert s ps'', Just c')++++c32 :: CircBlock++c32 (Nothing, ps@(_:_:_:_)) = do+ p1:p2:p3:ps' <- bus ps+ (s,c) <- flipX $ fullAdd (p1,(p2,p3))+ return (insert s ps', Just c)++c32 (Just c, ps@(_:_:_)) = do+ ps' <- bus ps+ let p1:p2:p3:ps'' = insert c ps'+ (s,c') <- flipX $ fullAdd (p1,(p2,p3))+ return (insert s ps'', Just c')++++wir :: CircBlock+wir (Just c, ps) = do+ ps' <- bus $ insert c ps+ return (ps', Nothing)++circBlock :: Block -> CircBlock+circBlock W = wir+circBlock H = c22+circBlock F = c32++++buildColumn+ :: [Block]+ -> ([Maybe Signal], [Signal])+ -> Wired Simple130nm ([Signal], [Maybe Signal])++buildColumn [] (_,ps) = return (ps,[])++buildColumn (b:bs) (c:cs, ps) = do+ (ps',cs') <- buildColumn bs (cs,ps)+ -- unless (b==W) $ space 500 ()+ (ss,c') <- circBlock b (c,ps')+ return (ss, c':cs')++++buildArray :: Int -> [[Block]] -> [[Signal]] -> Wired Simple130nm [[Signal]]+buildArray h bss pss = build bss [] pss+ where+ build [] _ _ = return []++ build (bs:bss) cs (ps:pss) = do+ (ss,cs') <- downwards $ do+ ps' <- space h' =<< bus ps+ (ss,cs') <- space 1000 =<< buildColumn+ (reverse bs) (cs ++ repeat Nothing, ps')+ ss' <- bus ss+ return (ss',cs')+ sss <- build bss cs' pss+ return (ss:sss)+ where+ h' = icast (h - length (filter (/=W) bs)) * icast rowHeight++++redArray :: [[Signal]] -> Wired Simple130nm [[Signal]]+redArray pss = rightwards $ buildArray h bss (pss ++ repeat [])+ where+ bss = redArrayBlock $ map length pss+ h = maximum $ map length bss++++inp n = sequence+ $ [inputList m "" | m <- [1..n]]+ ++ [inputList m "" | m <- reverse [1..n-1]]++redArrayIO = inp 12 >>= redArray++++test1 = renderWiredWithNets "circ" redArrayIO+
+ Examples/Sklansky.hs view
@@ -0,0 +1,29 @@+import Wired+import Libs.Simple130nm.Wired++++bus = rightwards . mapM bus1+ where+ bus1 = space 1200 >=> guideE 3 0 >=> space 850++sklansky op [a] = space 2050 [a]+sklansky op as = downwards' $ do+ bus as+ (ls',rs') <- rightwards $ ((sklansky op -|- sklansky op) . halveList) as+ rs'' <- rightwards $ sequence [op (last ls', r) | r <- rs']+ bus (ls' ++ rs'')+ -- Using downwards' to get alignment towards the right. In the future, this+ -- will be done using elastic space instead.++++sklanskyIO op = downwards .+ (bus >=> space 1000 >=> sklansky op >=> space 1000 >=> bus)++++test1 = renderWiredWithNets "circ" $ sklanskyIO and2 =<< inputList 28 "in"++test2 = simulate (stripLayout . sklansky and2) [1,1,1,1,0,1,1,0,1,1]+
+ Examples/UsingLava.hs view
@@ -0,0 +1,74 @@+import Lava+import Libs.Simple130nm.Lava++import qualified Lava2000 as L++import Control.Monad.Trans+import Data.Logical.Let+ -- Only used in circLoop2.++++circ1 :: (Signal,Signal) -> Lava Simple130nm Signal+circ1 = and2 ->- inv++circ1' (a,b) = do+ c <- and2 (a,b)+ inv c+ -- Same as circ1.++circ2 = halfAdd ->- and2 ->- inv++circLoop = mdo+ a <- label "a" =<< and2 (b,b)+ b <- label "b" =<< inv c+ c <- label "c" =<< and2 (b,a)+ return b+ -- Labels are not needed for definition.++circLoop2 = runLetT $ do+ b <- free+ c <- free+ a <- lift $ label "a" =<< and2 (val b, val b)+ b' <- lift $ label "b" =<< inv (val c)+ c' <- lift $ label "c" =<< and2 (val b, a)+ b === b'+ c === c'+ return b'+ -- Alternative definition using logical variables++circInput :: Signal -> Lava Simple130nm Signal+circInput a = do+ b <- input "b"+ and2 (a,b)++++test1 = L.simulateSeq (toLava2000 circ2) L.domain+ -- Simulation using Lava2000.++test2 = simulateSeq circ2 [(0,0),(1,1)]+ -- Simulation in Lava (uses Lava2000 internally).++test3 = verify circ2+ -- Check that output is always high.++test4 = fst $ depth $ circ1 (low,low)+ -- Find logcial depth of circ1.++test5 = fst $ depth circLoop+ -- Error because of combinational loop.++test6 = lookupTag "b" $ fanout circLoop+ -- Find the fanout at node "b". It is perfectly fine to have multiple labels+ -- on the same node, and even to use the same label on multiple places (try).++test7 = lookupTag "b" $ fanout circLoop2+ -- Just to test++test8 = size circLoop+ -- Find number of gates in circLoop.++test9 = simulate circInput 0+ -- Inputs can be defined, but they cause error in simulation.+
+ Examples/UsingWired.hs view
@@ -0,0 +1,58 @@+import Wired+import Libs.Simple130nm.Wired+import qualified Libs.Simple130nm.Lava as L++++circ1 = and2 ->- copy .>. and2 ->- copy .>. and2 ->- space 10000 {-nanometers-}++circ2 = rightwards $ circ1 (low,low)++circ3 = rightwards $ input "in" >>= circ1++circ3' = rightwards $ do+ (a,b) <- input "in"+ circ1 (a,b)+ -- Same as circ3. Note that input can create several inputs in one go.++circ4 = upwards $ input "in" >>= circ1++circ5 = rightwards+ $ input "in"+ >>= (rotate 3 . guideE 1 2000 {-nanometers-})+ >>= space 1000 {-nanometers-}+ >>= circ1+ -- In order to show the primary input nets, this definition has a guide+ -- followed by some space to the left of circ1. Since the input is a pair of+ -- signals, there are actually two guides beside each other. Each guide is+ -- 2000 units wide, and is located on metal layer 1. By rotating the guides,+ -- they get placed downwards instead of rigthwards.++circ6 = rightwards . (and2 >=> copy .>. L.and2 >=> space 4000)++++test1 = simulate (stripLayout . circ1) (1,1)+ -- A Wired circuit is easily converted to a Lava circuit.++test2 = renderWiredWithNets "circ" circ2+ -- Draws a picture of the layout to the file circ.ps. The space in circ1 is+ -- only to make the picture look smaller (it is always scaled to fit on an A4+ -- page). Note that the low inputs are connected in a single net.++test3 = renderWiredWithNets "circ" circ3+ -- Here each input is a separate net. Single-point nets are not drawn, so only+ -- the intermediate signal is shown.++test4 = renderWiredWithNets "circ" circ4+ -- Same circuit with upwards placement.++test5 = renderWiredWithNets "circ" $ rotate 1 circ3+ -- circ3 rotated 1 step counter-clockwise. Try also flipX and flipY.++test6 = renderWiredWithNets "circ" circ5++test7 = renderWiredWithNets "circ" $ circ6 (low,low)+ -- Lava gates can be used happily together with Wired gates. They just don't+ -- show up in the pictures.+
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Emil Axelsson 2008++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 Emil Axelsson 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.+
+ Lava.hs view
@@ -0,0 +1,34 @@+module Lava+ ( module Control.Monad+ , Signal+ , CellLibrary+ , Lava+ , MonadLava+ , InterpDesignDB+ , lookupTag+ , module Lava.Patterns+ , hasLoop+ , hasCombLoop+ , Port+ , PortStruct+ , PortFixed+ , input+ , inputList+ , label+ , toLava2000+ , simulateSeq+ , simulate+ , verify+ , depth+ , fanout+ , size+ ) where++++import Control.Monad++import Data.Hardware+import Lava.Patterns+import Lava.Internal+
+ Lava/Internal.hs view
@@ -0,0 +1,152 @@+module Lava.Internal+ ( module Lava.Model+ , module Lava.Patterns+ , module Lava.Loop+ , module Lava.Port+ , module Lava.Interpret+ , input+ , inputList+ , cell+ , label+ , toLava2000+ , simulateSeq+ , simulate+ , verify+ , depth+ , fanout+ , size+ ) where++++import Control.Monad+import qualified Data.Foldable as Fold+import qualified Data.Map as Map++import Data.Hardware.Internal+import Lava.Model+import Lava.Patterns+import Lava.Loop+import Lava.Port+import Lava.Interpret++import qualified Lava2000 as L+import qualified Lava2000.Ref as L++++input :: forall lib m p . (MonadLava lib m, PortFixed p Signal) => Name -> m p+input nm = liftM fromListFP $ replicateM (lengthFP (T::TypeOf p)) (inputSig nm)+ -- Declare a primary input++inputList :: (MonadLava lib m, PortFixed p Signal) => Int -> Name -> m [p]+inputList n nm = replicateM n $ input nm++++cell+ :: forall m lib pi po+ . ( MonadLava lib m+ , PortFixed pi Signal+ , PortFixed po Signal+ , CellLibrary lib+ )+ => lib -> pi -> m po++cell cid pi = liftM fromListFP $ cellList cid ins+ where+ ins = Fold.toList $ port pi+ -- Declare a cell++++label :: (MonadLava lib m, PortStruct p Signal t) => Tag -> p -> m p+label tag = mapPortM (labelSig tag)+ -- Declare a label; only side-effect important.++++toLava2000+ :: ( CellLibrary lib+ , PortStruct pli (L.Signal Bool) ti+ , PortStruct psi Signal ti+ , PortStruct pso Signal to+ , PortStruct plo (L.Signal Bool) to+ )+ => (psi -> Lava lib pso)+ -> (pli -> plo)++toLava2000 circ = fst . interpretFunc lava2000Interp circ++++simulateSeq+ :: ( CellLibrary lib+ , PortStruct pni Int ti+ , PortStruct psi Signal ti+ , PortStruct pso Signal to+ , PortStruct pno Int to+ )+ => (psi -> Lava lib pso)+ -> ([pni] -> [pno])++simulateSeq circ+ = map (unport . fmap sigToInt)+ . L.simulateSeq circP+ . map (fmap intToSig . port)+ where+ circP = fst . interpretFuncP lava2000Interp (liftM port . circ . unport)++ intToSig 0 = L.low+ intToSig 1 = L.high+ intToSig _ = error "Only values 0 and 1 allowed"++ sigToInt (L.Signal (L.Symbol r)) = case L.deref r of+ L.Bool False -> 0+ L.Bool True -> 1++++simulate+ :: ( CellLibrary lib+ , PortStruct pni Int ti+ , PortStruct psi Signal ti+ , PortStruct pso Signal to+ , PortStruct pno Int to+ )+ => (psi -> Lava lib pso)+ -> (pni -> pno)++simulate circ = head . simulateSeq circ . return++++verify+ :: forall lib ps+ . (CellLibrary lib, PortFixed ps Signal)+ => (ps -> Lava lib Signal) -> IO ()++verify circ = L.smv (L.forAll (L.list n) circP) >> return ()+ where+ n = lengthFP (T::TypeOf ps)++ circP = toLava2000 (circ . fromListFP)++++depth :: (CellLibrary lib, PortStruct ps Signal t, PortStruct pd Int t) =>+ Lava lib ps -> (pd, InterpDesignDB lib Int)+depth circ+ | hasLoopDB True db = error "depth: Combinational feedback loop"+ | otherwise = pd_idb+ where+ pd_idb@(_,(db,_)) = interpret depthInterp circ++fanout :: CellLibrary lib => Lava lib a -> InterpDesignDB lib Int+fanout circ = (db, fmap length $ fanoutDB db)+ where+ (_,db) = runLava circ++size :: CellLibrary lib => Lava lib p -> Int+size = length . Map.toList . cellDB . snd . runLava+
+ Lava/Interpret.hs view
@@ -0,0 +1,122 @@+module Lava.Interpret where++++import Control.Arrow ((***))+import Control.Monad.State+import qualified Data.Foldable as Fold+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Traversable as Trav++import Data.Hardware.Internal+import Data.Logical.Knot+import Lava.Model+import Lava.Port++++askSig :: Interpretation lib x -> Signal -> Knot Signal x x+askSig interp = askKnotDef (defaultVal interp)++tellSigs :: Interpretation lib x -> [Signal] -> [Maybe x] -> Knot Signal x ()+tellSigs interp sigs vals = sequence_ [sig*=x | (sig, Just x) <- zip sigs vals]++++interpretCells :: forall lib x+ . CellLibrary lib+ => Interpretation lib x+ -> [(Signal, x)]+ -> [(CellId, (lib,[Signal]))]+ -> Map Signal x++interpretCells interp es cells = snd $ accKnot (accumulator interp) $ do++ sequence_ [s*=x | (s,x) <- es']+ -- Constrain explicitly interpreted signals.++ forM_ cells $ \(cid,(ct,ins)) -> do+ let sigs = cellOutputs cid ct ++ ins+ vals <- mapM (askSig interp) sigs+ tellSigs interp sigs $ propagator interp ct vals+ -- Propagate values across each cell.++ where+ es' = zip (libraryConstants (T::TypeOf lib)) (constants interp) ++ es+ -- Add constants to list of explicitly interpreted signals++ -- es is a list of explicit signal interpretations. The signals mentioned in+ -- this list must be valid according to prop_validSignals.++++interpret_+ :: CellLibrary lib+ => Interpretation lib x+ -> [(Signal, x)]+ -> Lava lib (PortTree Signal)+ -> (PortTree x, InterpDesignDB lib x)++interpret_ interp es lava = (fmap (sigMap Map.!) ps, (db,sigMap))+ where+ (ps,db) = runLava lava+ sigMap = interpretCells interp es (Map.toList $ cellDB db)++++interpret+ :: ( CellLibrary lib+ , PortStruct ps Signal t+ , PortStruct px x t+ )+ => Interpretation lib x -> Lava lib ps -> (px, InterpDesignDB lib x)++interpret interp = (unport *** id) . interpret_ interp [] . liftM port++++inputToSig :: PortTree x -> PortTree Signal+inputToSig = flip evalState (-1) . Trav.mapM toSig+ where+ toSig x = do+ iid <- get+ put (pred iid)+ return $ PrimInpSig iid+ -- Using negative indices to aviod clash with user-defined primary inputs.++++interpretFuncP+ :: CellLibrary lib+ => Interpretation lib x+ -> (PortTree Signal -> Lava lib (PortTree Signal))+ -> (PortTree x -> (PortTree x, InterpDesignDB lib x))++interpretFuncP interp fs pxi = interpret_ interp es (fs psi)+ where+ psi = inputToSig pxi+ es = Fold.toList psi `zip` Fold.toList pxi++ -- Note that the signals in psi will not be present in db in interpret_, so+ -- technically the database may not be valid. It would be possible to pass+ -- them separately and add to the database, but there's no point in doing+ -- that, since interpret_ only cares about the cells in db.++++interpretFunc+ :: ( CellLibrary lib+ , PortStruct pxi x ti+ , PortStruct psi Signal ti+ , PortStruct pso Signal to+ , PortStruct pxo x to+ )+ => Interpretation lib x+ -> (psi -> Lava lib pso)+ -> (pxi -> (pxo, InterpDesignDB lib x))++interpretFunc interp f = (unport *** id) . interpretFuncP interp fP . port+ where+ fP = liftM port . f . unport+
+ Lava/Loop.hs view
@@ -0,0 +1,88 @@+module Lava.Loop+ ( hasLoopDB+ , hasLoop+ , hasCombLoop+ ) where++++import Control.Monad.State+import Data.Map (Map)+import qualified Data.Map as Map++import Data.Hardware.Internal+import Lava.Model++++data Status+ = NotVisited+ | Visiting+ | Done++type Visit = State (Map CellId Status)++++cellStatus :: CellId -> Visit Status+cellStatus cid = do+ statMap <- get+ case Map.lookup cid statMap of+ Nothing -> return NotVisited+ Just stat -> return stat++setCellStatus :: CellId -> Status -> Visit ()+setCellStatus i stat = modify (Map.insert i stat)++setVisiting :: CellId -> Visit ()+setVisiting i = setCellStatus i Visiting++setDone :: CellId -> Visit ()+setDone i = setCellStatus i Done++isVisited :: CellId -> Visit Bool+isVisited i = do+ st <- cellStatus i+ return $ case st of+ NotVisited -> False+ _ -> True++++anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM f [] = return False+anyM f (a:as) = do+ b <- f a+ if b then return True+ else anyM f as+ -- Checks lazily if the predicate holds for any element.++++hasLoopDB :: CellLibrary lib => Bool -> DesignDB lib -> Bool+hasLoopDB comb db =+ fst $ runState (anyM loop (Map.toList $ cellDB db)) Map.empty+ where+ loop (cid,(ct,ins))+ | comb && isFlop ct = setDone cid >> return False++ loop (cid,(ct,ins)) = do+ stat <- cellStatus cid+ case stat of+ Done -> return False+ Visiting -> return True++ _ -> do+ setVisiting cid+ l <- anyM loop [(c, cellDB db Map.! c) | CellSig c _ <- ins]+ setDone cid+ return l++++hasLoop :: CellLibrary lib => Lava lib a -> Bool+hasLoop = hasLoopDB False . snd . runLava++hasCombLoop :: CellLibrary lib => Lava lib a -> Bool+hasCombLoop = hasLoopDB True . snd . runLava+
+ Lava/Model.hs view
@@ -0,0 +1,259 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Lava.Model where++++import Control.Monad.Writer+import Control.Monad.State+import Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map++import Data.Hardware.Internal++import qualified Lava2000 as L++++data Signal+ = Constant ConstId+ | PrimInpSig PrimInpId+ | CellSig CellId Pin+ -- The pins of a cell are numbered consequtively from 0, starting+ -- with the outputs.+ deriving (Eq, Show, Ord)++data Declaration lib+ = PrimInput PrimInpId Name+ | Cell CellId lib [Signal]+ | Label Tag Signal+ deriving (Eq, Show)++data DesignDB lib = DesignDB+ { inputDB :: Map PrimInpId Name+ , cellDB :: Map CellId (lib,[Signal])+ , fanoutDB :: Map Signal [Signal]+ , tagDB :: Map Tag [Signal]+ }+ deriving (Eq, Show)+ -- fanoutDB and tagDB need only be defined if the value is non-empty. Use+ -- together with totalLookup. A database is valid if the corresponding list+ -- of declarations is (*** it should be possible to reconstruct a list of+ -- declarations from a database to make this well-defined).++++class CellLibrary lib+ where+ numConsts :: TypeOf lib -> ConstId+ -- Only used for specifying valid circuits (see prop_validDecls).++ numIns :: lib -> Int+ numOuts :: lib -> Int+ -- Number of inputs/outputs of the given cell++ pinName :: lib -> Pin -> Name+ pinId :: lib -> Name -> Pin++ isFlop :: lib -> Bool+ -- Tells whether or not the given cell is a flipflop.++ lava2000Interp :: Interpretation lib (L.Signal Bool)++ -- Requirements:+ --+ -- * The range of numConsts, numIns and numOuts is a subset of [0..]+ --+ -- * The domain of (pinName c) is [0 .. numOuts c + numIns c - 1]+ --+ -- * (pinName c) is one-to-one, and its inverse is (pinId c).+ --+ -- * lava2000Interp is a valid interpretation (see definition of+ -- Interpretation). Moreover, the propagator method should constrain all+ -- and only all outputs of each cell.++++libraryConstants :: CellLibrary lib => TypeOf lib -> [Signal]+libraryConstants t = map Constant [0 .. numConsts t-1]++cellInputs :: CellLibrary lib => CellId -> lib -> [Signal]+cellInputs cid ct = map (CellSig cid) [no .. no+ni]+ where+ no = icast (numOuts ct)+ ni = icast (numIns ct)++cellOutputs :: CellLibrary lib => CellId -> lib -> [Signal]+cellOutputs cid ct = map (CellSig cid) [0 .. icast (numOuts ct) - 1]++++prop_uniquePrimInputs decls = iids == nub iids+ where+ iids = [iid | PrimInput iid _ <- decls]+ -- Each PrimInput has a uniqe PrimInpId.++prop_uniqueCells decls = cids == nub cids+ where+ cids = [cid | Cell cid _ _ <- decls]+ -- Each Cell has a uniqe CellId.++prop_correctCellInputs decls =+ and [numIns ct == length ss | Cell _ ct ss <- decls]+ -- Each Cell has the correct number of inputs.++++prop_validSignals :: forall lib . CellLibrary lib => [Declaration lib] -> Bool+prop_validSignals decls = all (`elem` validSigs) referred+ where+ primInps = [PrimInpSig iid | PrimInput iid _ <- decls]+ cellOuts = [s | Cell cid ct _ <- decls, s <- cellOutputs cid ct]+ validSigs = libraryConstants (T::TypeOf lib) ++ primInps ++ cellOuts++ referred+ = concat [ss | Cell _ _ ss <- decls]+ ++ [s | Label _ s <- decls]+ -- All signals referred to in the declarations++ -- Checks that all signals referred to by a Cell or Label are valid. The valid+ -- signals are the constants defined by the library, the declared primary+ -- inputs and the *outputs* of declared cells. It is not allowed to refer to+ -- cell inputs.++++prop_validDecls :: CellLibrary lib => [Declaration lib] -> Bool+prop_validDecls decls+ = prop_uniquePrimInputs decls+ && prop_uniqueCells decls+ && prop_correctCellInputs decls -- Correct number of inputs for each cell+ && prop_validSignals decls -- No reference to invalid signals++ -- A circuit is always defined in the presence of a cell library. This+ -- property defines what it means for a list of declarations to be valid with+ -- respect to a cell library.+ --+ -- The properties should be fulfilled as long as the requirements of the+ -- CellLibrary class are met and all signals are created using the methods:+ -- libraryConstants, input, cell, and label.+ --+ -- The only thing that can go wrong is if the number of inputs/outputs+ -- demanded by the type of a cell is different from what is specified by+ -- numIns/numOuts. Difference in the inputs won't be checked at all (and the+ -- only place where it might matter is in the propagator method of an+ -- interpretation). However, difference in the outputs is checked for by+ -- fromListFP (but the error is non-informative).++++newtype Lava lib a = Lava+ { unLava :: WriterT [Declaration lib] (State (PrimInpId,CellId)) a }+ deriving (Monad, MonadFix)++++runLava :: CellLibrary lib => Lava lib a -> (a, DesignDB lib)+runLava (Lava lava) = (a, makeDesignDB decls)+ where+ ((a,decls),_) = runState (runWriterT lava) (0,0)++ fanouts decls = Map.fromListWith (++) $ concat+ [ zip ins (map return $ cellInputs cid ct) | Cell cid ct ins <- decls ]++ makeDesignDB decls = DesignDB iDB cDB (fanouts decls) tDB+ where+ iDB = Map.fromList [(iid,nm) | PrimInput iid nm <- decls]+ cDB = Map.fromList [(cid,(ct,ins)) | Cell cid ct ins <- decls]+ tDB = Map.fromListWith (++) [(tag,[sig]) | Label tag sig <- decls]++++class (Monad m, CellLibrary lib) => MonadLava lib m | m -> lib+ where+ newPrimInpId :: m PrimInpId+ newCellId :: m CellId++ declare :: Declaration lib -> m ()++ listenDecls :: m a -> m (a, [Declaration lib])++instance CellLibrary lib => MonadLava lib (Lava lib)+ where+ newPrimInpId = Lava $ do+ (iid,cid) <- get+ put (succ iid, cid)+ return iid++ newCellId = Lava $ do+ (iid,cid) <- get+ put (iid, succ cid)+ return cid++ declare = Lava . tell . return++ listenDecls = Lava . listen . unLava++++inputSig :: MonadLava lib m => Name -> m Signal+inputSig nm = do+ iid <- newPrimInpId+ declare $ PrimInput iid nm+ return (PrimInpSig iid)+ -- Declare a primary input++cellList :: MonadLava lib m => lib -> [Signal] -> m [Signal]+cellList ct ins = do+ cid <- newCellId+ declare $ Cell cid ct ins+ return (cellOutputs cid ct)+ -- Declare a cell++labelSig :: MonadLava lib m => Tag -> Signal -> m Signal+labelSig tag sig = declare (Label tag sig) >> return sig+ -- Declare a label; only side-effect important++++data Interpretation lib x = Interp+ { constants :: [x]+ , defaultVal :: x+ , accumulator :: x -> x -> x+ , propagator :: lib -> ([x] -> [Maybe x])+ -- The value of pin p appears at position p in the lists (i.e.+ -- outputs first).+ }++ -- Requirements:+ --+ -- * The length of the constant list is (numConsts (T::TypeOf lib)).+ --+ -- * The number of elements accepted/returned by the propagator is+ -- (numOuts cell + numIns cell).++++type InterpDesignDB lib x = (DesignDB lib, Map Signal x)++++lookupTag :: Tag -> InterpDesignDB lib x -> [x]+lookupTag tag (db,sigMap) = map (sigMap Map.!) (tag `totalLookup` tagDB db)++depthInterp :: forall lib . CellLibrary lib => Interpretation lib Int+depthInterp = Interp+ { constants = replicate (icast $ numConsts (T::TypeOf lib)) 0+ , propagator = prop+ }+ where+ prop ct vals+ | isFlop ct = replicate no (Just 0) ++ ins+ | otherwise = replicate no (Just (d+1)) ++ ins+ where+ ni = numIns ct+ no = numOuts ct+ ins = replicate ni Nothing+ d = maximum (drop no vals)+
+ Lava/Patterns.hs view
@@ -0,0 +1,138 @@+module Lava.Patterns where++++import Control.Monad++import Lava.Model++++infixr 6 .<., .>.++(.<.) :: (b -> c) -> (a -> b) -> (a -> c)+(.<.) = (.)++(.>.) :: (a -> b) -> (b -> c) -> (a -> c)+(.>.) = flip (.)++swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)++swapl :: [a] -> [a]+swapl [a,b] = [b,a]++copy :: a -> (a,a)+copy a = (a,a)++halveList :: [a] -> ([a],[a])+halveList as = (as1,as2)+ where+ half = length as `div` 2+ (as1,as2) = splitAt half as++zipp :: ([a],[b]) -> [(a,b)]+zipp ([],[]) = []+zipp (a:as, b:bs) = (a,b) : zipp (as, bs)+zipp _ = error "Lava.Patterns.zipp: Different lengths"++unzipp :: [(a,b)] -> ([a],[b])+unzipp = unzip++riffle :: [a] -> [a]+riffle = halveList .>. zipp .>. unpair++unriffle :: [a] -> [a]+unriffle = pair .>. unzipp .>. append++pair :: [a] -> [(a,a)]+pair (x:y:xs) = (x,y) : pair xs+pair _ = []++unpair :: [(a,a)] -> [a]+unpair [] = []+unpair ((x,y):xys) = x : y : unpair xys++append :: ([a],[a]) -> [a]+append = uncurry (++)++mon :: Monad m => (a -> b) -> (a -> m b)+mon = (return .)+ -- Make a function monadic, e.g. so that it can be composed with other monadic+ -- computations using (>=>).++++infixr 5 ->-, -<-+infixr 4 -|-++(->-) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+(->-) = (>=>)++(-<-) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)+(-<-) = (<=<)++serial :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+serial = (>=>)++compose :: Monad m => [a -> m a] -> (a -> m a)+compose [] = return+compose (c:cs) = c >=> compose cs++composeN :: Monad m => Int -> (a -> m a) -> (a -> m a)+composeN n = compose . replicate n++(-|-) :: Monad m => (a -> m b) -> (c -> m d) -> ((a,c) -> m (b,d))+circ1 -|- circ2 = \(a,c) -> liftM2 (,) (circ1 a) (circ2 c)++par :: Monad m => (a -> m b) -> (c -> m d) -> ((a,c) -> m (b,d))+par = (-|-)++parl :: Monad m => ([a] -> m [b]) -> ([a] -> m [b]) -> ([a] -> m [b])+parl circ1 circ2 = halveList .>. (circ1 -|- circ2) ->- mon append++two :: Monad m => ([a] -> m [b]) -> ([a] -> m [b])+two circ = parl circ circ++ilv :: Monad m => ([a] -> m [b]) -> ([a] -> m [b])+ilv circ = unriffle .>. two circ ->- mon riffle++iter+ :: Monad m+ => Int -> ((a -> m b) -> (a -> m b)) -> ((a -> m b) -> (a -> m b))+iter 0 comb = id+iter n comb = comb . iter (n-1) comb++twoN :: Monad m => Int -> ([a] -> m [b]) -> ([a] -> m [b])+twoN n = iter n two++ilvN :: Monad m => Int -> ([a] -> m [b]) -> ([a] -> m [b])+ilvN n = iter n ilv++bfly :: Monad m => Int -> ([a] -> m [a]) -> ([a] -> m [a])+bfly 0 circ = return+bfly n circ = ilv (bfly (n-1) circ) ->- twoN (n-1) circ++pmap :: Monad m => ((a,a) -> m (b,b)) -> ([a] -> m [b])+pmap circ = pair .>. mapM circ ->- mon unpair++tri :: Monad m => (a -> m a) -> ([a] -> m [a])+tri circ [] = return []+tri circ (a:as) = liftM (a:) $ (tri circ -<- mapM circ) as++mirror :: Monad m => ((a,b) -> m (c,d)) -> ((b,a) -> m (d,c))+mirror circ = swap .>. circ ->- mon swap++row :: Monad m => ((a,b) -> m (c,a)) -> ((a,[b]) -> m ([c],a))+row circ (a,[]) = return ([],a)+row circ (a, b:bs) = do+ (c,a') <- circ (a,b)+ (cs,a'') <- row circ (a',bs)+ return (c:cs, a'')++column :: Monad m => ((a,b) -> m (b,c)) -> (([a],b) -> m (b,[c]))+column = mirror . row . mirror++grid :: Monad m => ((a,b) -> m (b,a)) -> (([a],[b]) -> m ([b],[a]))+grid = row . column+
+ Lava/Port.hs view
@@ -0,0 +1,193 @@+module Lava.Port where++++import Control.Applicative+import Control.Monad+import Data.Foldable (Foldable)+import qualified Data.Foldable as Fold+import Data.List as List+import Data.Traversable (Traversable, traverse)+import qualified Data.Traversable as Trav++import Data.Hardware.Internal+import Lava.Model++import qualified Lava2000 as L++++data PortTree s+ = One {unOne :: s}+ | List [PortTree s]+ deriving (Eq, Show)++instance Functor PortTree+ where+ fmap f (One s) = One (f s)+ fmap f (List ps) = List $ map (fmap f) ps++instance Foldable PortTree+ where+ foldr f x (One s) = f s x+ foldr f x (List ps) = List.foldr (flip $ Fold.foldr f) x ps++instance Traversable PortTree+ where+ traverse f (One s) = pure One <*> f s+ traverse f (List ps) = pure List <*> traverse (traverse f) ps++++class Port p s | p -> s+ where+ port :: p -> PortTree s+ unport :: PortTree s -> p++instance Port Signal Signal+ where+ port = One+ unport = unOne++instance Port () ()+ where+ port = One+ unport = unOne++instance Port Bool Bool+ where+ port = One+ unport = unOne++instance Port Int Int+ where+ port = One+ unport = unOne++instance Port (L.Signal Bool) (L.Signal Bool)+ where+ port = One+ unport = unOne++instance Port p s => Port [p] s+ where+ port = List . map port+ unport (List ps) = map unport ps++instance (Port p1 s, Port p2 s) => Port (p1,p2) s+ where+ port (p1,p2) = List [port p1, port p2]+ unport (List [p1,p2]) = (unport p1, unport p2)++instance (Port p1 s, Port p2 s, Port p3 s) => Port (p1,p2,p3) s+ where+ port (p1,p2,p3) = List [port p1, port p2, port p3]+ unport (List [p1,p2,p3]) = (unport p1, unport p2, unport p3)++instance (Port p1 s, Port p2 s, Port p3 s, Port p4 s) => Port (p1,p2,p3,p4) s+ where+ port (p1,p2,p3,p4) = List [port p1, port p2, port p3, port p4]+ unport (List [p1,p2,p3,p4]) = (unport p1, unport p2, unport p3, unport p4)++++class Port p s => PortStruct p s t | p -> s t, s t -> p++instance PortStruct Signal Signal ()+instance PortStruct () () ()+instance PortStruct Bool Bool ()+instance PortStruct Int Int ()+instance PortStruct (L.Signal Bool) (L.Signal Bool) ()+instance PortStruct p s t => PortStruct [p] s [t]++instance (PortStruct p1 s t1, PortStruct p2 s t2)+ => PortStruct (p1,p2) s (t1,t2)++instance (PortStruct p1 s t1, PortStruct p2 s t2, PortStruct p3 s t3)+ => PortStruct (p1,p2,p3) s (t1,t2,t3)++instance ( PortStruct p1 s t1+ , PortStruct p2 s t2+ , PortStruct p3 s t3+ , PortStruct p4 s t4+ )+ => PortStruct (p1,p2,p3,p4) s (t1,t2,t3,t4)++++mapPort :: (PortStruct pa sa t, PortStruct pb sb t) => (sa -> sb) -> (pa -> pb)+mapPort f = unport . fmap f . port++mapPortM+ :: (PortStruct pa sa t, PortStruct pb sb t, Monad m)+ => (sa -> m sb) -> (pa -> m pb)+mapPortM f = liftM unport . Trav.mapM f . port++++class Port p s => PortFixed p s | p -> s+ where+ lengthFP :: TypeOf p -> Int+ fromListFP :: [s] -> p++instance PortFixed Signal Signal+ where+ lengthFP = const 1+ fromListFP [s] = s++instance (PortFixed p1 s, PortFixed p2 s) => PortFixed (p1,p2) s+ where+ lengthFP = const $ lengthFP (T::TypeOf p1) + lengthFP (T::TypeOf p2)++ fromListFP ss = (fromListFP ss1, fromListFP ss2)+ where+ (ss1,ss2) = splitAt (lengthFP (T::TypeOf p1)) ss++instance ( PortFixed p1 s+ , PortFixed p2 s+ , PortFixed p3 s+ )+ => PortFixed (p1,p2,p3) s+ where+ lengthFP = const+ $ lengthFP (T::TypeOf p1)+ + lengthFP (T::TypeOf p2)+ + lengthFP (T::TypeOf p3)++ fromListFP ss = (fromListFP ss1, fromListFP ss2, fromListFP ss3)+ where+ (ss1,ss23) = splitAt (lengthFP (T::TypeOf p1)) ss+ (ss2,ss3) = splitAt (lengthFP (T::TypeOf p2)) ss23++instance ( PortFixed p1 s+ , PortFixed p2 s+ , PortFixed p3 s+ , PortFixed p4 s+ )+ => PortFixed (p1,p2,p3,p4) s+ where+ lengthFP = const+ $ lengthFP (T::TypeOf p1)+ + lengthFP (T::TypeOf p2)+ + lengthFP (T::TypeOf p3)+ + lengthFP (T::TypeOf p4)++ fromListFP ss =+ (fromListFP ss1, fromListFP ss2, fromListFP ss3, fromListFP ss4)+ where+ (ss1,ss234) = splitAt (lengthFP (T::TypeOf p1)) ss+ (ss2,ss34) = splitAt (lengthFP (T::TypeOf p2)) ss234+ (ss3,ss4) = splitAt (lengthFP (T::TypeOf p3)) ss34++++instance L.Generic (PortTree (L.Signal Bool))+ where+ struct (One (L.Signal sym)) = L.Object sym+ struct (List ss) = L.Compound (map L.struct ss)++ construct (L.Object sym) = One (L.Signal sym)+ construct (L.Compound ss) = List (map L.construct ss)++ -- This Lava2000 class corresponds roughly to the Port class.+
+ Layout.hs view
@@ -0,0 +1,32 @@+module Layout+ ( Transformable (..)+ , rotate+ , Layout+ , LayoutT+ , renderLayout+ , renderLayoutT+ , MonadLayout (..)+ , space+ , rightwards+ , leftwards+ , upwards+ , downwards+ , rightwards'+ , leftwards'+ , upwards'+ , downwards'+ , unplaced+ , stacked+ , translate+ ) where++++-- Layout is supposed to be used in specialized libraries where the s and b+-- parameters to are hardcoded to something useful. This module exports+-- functions that can be used in any such specialization.++++import Layout.Internal+
+ Layout/Floorplan.hs view
@@ -0,0 +1,287 @@+module Layout.Floorplan where++++import Control.Arrow ((***))+import Control.Monad.Writer++import Data.Hardware.Internal++++data Alignment+ = BottomLeft+ | TopRight+ deriving (Eq, Show)++newtype Elasticity = Elasticity Int+ deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)++data Distance+ = Dist Length -- Absolute distance+ -- *** | Fill Elasticity -- Relative distance+ deriving (Eq, Show)++data Block spaceSize s b+ = Space spaceSize (Maybe s)+ | Box Size Orientation Name b+ deriving (Eq, Show)+ -- Space *may* have some extra info. A Box is *always* associated with extra+ -- info (use () if not needed).++type RelBlock s b = Block Distance s b+ -- Space has only a distance. Angle is determined by the context.++type AbsBlock s b = Block (Angle,Length) s b+ -- Space is a horizontal or vertical line.++data Placement+ = Unspecified+ | Stack Alignment Alignment -- Stacked on the same position+ | Row Direction Alignment+ deriving (Eq, Show)++data Floorplan s b+ = Block (RelBlock s b)+ | Comb Placement [Floorplan s b]+ deriving (Eq, Show)++type AbsFloorplan s b = [(Position, AbsBlock s b)]++++class Transformable a+ where+ flipX :: a -> a+ flipY :: a -> a+ rotate_ :: Int -> a -> a++instance Transformable Direction+ where+ flipX Rightwards = Leftwards+ flipX Leftwards = Rightwards+ flipX dir = dir++ flipY Upwards = Downwards+ flipY Downwards = Upwards+ flipY dir = dir++ rotate_ n dir = iterate rot dir !! n+ where+ rot Rightwards = Upwards+ rot Leftwards = Downwards+ rot Upwards = Leftwards+ rot Downwards = Rightwards++instance Transformable Orientation+ where+ flipX (flipped,dir) = (not flipped, dir)++ flipY (flipped,Upwards) = (not flipped, Downwards)+ flipY (flipped,Downwards) = (not flipped, Upwards)+ flipY (flipped,Leftwards) = (not flipped, Rightwards)+ flipY (flipped,Rightwards) = (not flipped, Leftwards)++ rotate_ n (flipped,dir) = (flipped, rotate_ n dir)++instance Transformable (RelBlock s b)+ where+ flipX (Box sz ori nm b) = Box sz (flipX ori) nm b+ flipX bl = bl++ flipY (Box sz ori nm b) = Box sz (flipY ori) nm b+ flipY bl = bl++ rotate_ n (Box wh@(w,h) ori nm b) = Box wh' (rotate_ n ori) nm b+ where+ wh' = if even n then wh else (icast h, icast w)++ rotate_ n bl = bl++instance Transformable Placement+ where+ flipX (Stack alx aly) = Stack (flipAlignment alx) aly+ flipX (Row Rightwards al) = Row Leftwards al+ flipX (Row Leftwards al) = Row Rightwards al+ flipX (Row up_down al) = Row up_down (flipAlignment al)+ flipX pl = pl++ flipY (Stack alx aly) = Stack alx (flipAlignment aly)+ flipY (Row Upwards al) = Row Downwards al+ flipY (Row Downwards al) = Row Upwards al+ flipY (Row left_right al) = Row left_right (flipAlignment al)+ flipY pl = pl++ rotate_ n pl = iterate rot pl !! n+ where+ rot (Stack alx aly) = Stack (flipAlignment aly) alx+ rot (Row Rightwards al) = Row Upwards (flipAlignment al)+ rot (Row Leftwards al) = Row Downwards (flipAlignment al)+ rot (Row Upwards al) = Row Leftwards al+ rot (Row Downwards al) = Row Rightwards al+ rot pl = pl++instance Transformable (Floorplan s b)+ where+ flipX (Block bl) = Block (flipX bl)+ flipX (Comb pl fps) = Comb (flipX pl) (map flipX fps)++ flipY (Block bl) = Block (flipY bl)+ flipY (Comb pl fps) = Comb (flipY pl) (map flipY fps)++ rotate_ n (Block bl) = Block (rotate_ n bl)+ rotate_ n (Comb pl fps) = Comb (rotate_ n pl) $ map (rotate_ n) fps++++flipAlignment BottomLeft = TopRight+flipAlignment TopRight = BottomLeft++rotate :: Transformable a => Int -> a -> a+rotate n = rotate_ ((n`mod`4 + 4) `mod` 4)++++absolutizeBlock :: Placement -> RelBlock s b -> (AbsBlock s b, Size)++absolutizeBlock _ (Box sz ori nm b) = (Box sz ori nm b, sz)+ -- *** Could use unsafeCoerce to avoid reconstruction.++absolutizeBlock (Row dir _) (Space (Dist d) ms) = case ang of+ Horizontal -> (Space (ang,d) ms, (icast d, 0))+ Vertical -> (Space (ang,d) ms, (0, icast d))+ where+ ang = directionAngle dir++absolutizeBlock _ (Space _ ms) = (Space (Horizontal,0) ms, (0,0))++++align :: Integral i => Alignment -> i -> i -> i+align BottomLeft _ _ = 0+align _ smaller larger = larger - smaller++translateBlocks :: Position -> AbsFloorplan s b -> AbsFloorplan s b+translateBlocks (x,y) = map (transP *** id)+ where+ transP (x',y') = (x'+x,y'+y)++++absolutize_+ :: Placement+ -> Position+ -> Floorplan s b+ -> Writer (AbsFloorplan s b) Size++absolutize_ pl pos (Block bl) = do+ tell [(pos,abl)]+ return sz+ where+ (abl,sz) = absolutizeBlock pl bl++absolutize_ _ pos (Comb pl' [fp]) = absolutize_ pl' pos fp++absolutize_ pl pos (Comb (Row Leftwards al) fps) = absolutize_ pl pos $+ Comb (Row Rightwards al) $ reverse fps++absolutize_ pl pos (Comb (Row Downwards al) fps) = absolutize_ pl pos $+ Comb (Row Upwards al) $ reverse fps++absolutize_ _ _ (Comb _ []) = return (0,0)++absolutize_ pl (x,y) (Comb pl'@(Row Rightwards al) (fp:fps))++ | h1 < h2 = do+ tell $ translateBlocks (0, align al h1 h2) afp1+ tell afp2+ return (w1+w2, h2)++ | otherwise = do+ tell afp1+ tell $ translateBlocks (0, align al h2 h1) afp2+ return (w1+w2, h1)++ where+ ((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp+ ((w2,h2),afp2) = runWriter $ absolutize_ pl (x+w1, y) (Comb pl' fps)++absolutize_ pl (x,y) (Comb pl'@(Row Upwards al) (fp:fps))+ | w1 < w2 = do+ tell $ translateBlocks (align al w1 w2, 0) afp1+ tell afp2+ return (w2, h1+h2)++ | otherwise = do+ tell afp1+ tell $ translateBlocks (align al w2 w1, 0) afp2+ return (w1, h1+h2)++ where+ ((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp+ ((w2,h2),afp2) = runWriter $ absolutize_ pl (x, y+h1) (Comb pl' fps)++absolutize_ pl (x,y) (Comb pl'@(Stack alx aly) (fp:fps)) =+ case (compare w1 w2, compare h1 h2) of++ (LT,LT) -> do+ tell $ translateBlocks (align alx w1 w2, align aly h1 h2) afp1+ tell afp2+ return (w2,h2)++ (GT,GT) -> do+ tell afp1+ tell $ translateBlocks (align alx w2 w1, align aly h2 h1) afp2+ return (w1,h1)++ (LT,_) -> do+ tell $ translateBlocks (align alx w1 w2, 0) afp1+ tell $ translateBlocks (0, align aly h2 h1) afp2+ return (w2,h1)++ _ -> do+ tell $ translateBlocks (0, align aly h1 h2) afp1+ tell $ translateBlocks (align alx w2 w1, 0) afp2+ return (w1,h2)++ where+ ((w1,h1),afp1) = runWriter $ absolutize_ pl' (x,y) fp+ ((w2,h2),afp2) = runWriter $ absolutize_ pl (x,y) (Comb pl' fps)++absolutize_ pl pos fp@(Comb Unspecified fps) = return rt+ -- *** Should do something more...+ where+ areaFP fp = icast x * icast y :: Int+ where+ (x,y) = fst $ runWriter $ absolutize_ pl pos fp++ totArea = sum $ map areaFP fps++ side :: Int+ side = fromInteger+ $ round+ $ sqrt+ $ fromIntegral+ $ totArea++ rt = (icast side, icast side)++ -- The Placement argument is the placement of the node immediately above the+ -- current one. It is only used for blocks.++ -- *** The same block may be translated over and over again. If the size of+ -- each sub-floorplan was known in advance, this could be avioded (by+ -- adjusting the position argument to absolutize_ for alignment).++++absolutize :: Floorplan s b -> (AbsFloorplan s b, Size)+absolutize fp = (afp,topRight)+ where+ (topRight,afp) = runWriter $ absolutize_ Unspecified (0,0) fp++blockCenter :: (Position, AbsBlock s b) -> Position+blockCenter ((x,y), Space (Horizontal,len) _) = (x + icast len`div`2, y)+blockCenter ((x,y), Space (Vertical, len) _) = (x, y + icast len`div`2)+blockCenter ((x,y), Box (w,h) _ _ _) = (x + w`div`2, y + h`div`2)+
+ Layout/Internal.hs view
@@ -0,0 +1,173 @@+module Layout.Internal+ ( module Layout.Floorplan+ , module Layout.Postscript+ , Layout (..)+ , LayoutT (..)+ , runLayout+ , runLayoutT+ , renderLayout+ , renderLayoutT+ , MonadLayout (..)+ , space+ , block+ , rightwards+ , leftwards+ , upwards+ , downwards+ , rightwards'+ , leftwards'+ , upwards'+ , downwards'+ , unplaced+ , stacked+ , translate+ ) where++++import Control.Monad.Reader+import Control.Monad.Writer++import Data.Hardware.Internal+import Layout.Floorplan+import Layout.Postscript++++newtype Layout s b a = Layout+ (ReaderT Placement (Writer [Floorplan s b]) a)+ deriving (Monad, MonadFix)++newtype LayoutT s b m a = LayoutT+ (ReaderT Placement (WriterT [Floorplan s b] m) a)+ deriving (Monad, MonadFix)++++runLayout :: Layout s b a -> (a, Floorplan s b)+runLayout (Layout m) = (a, Comb Unspecified fps)+ where+ (a,fps) = runWriter $ flip runReaderT Unspecified m++runLayoutT :: Monad m => LayoutT s b m a -> m (a, Floorplan s b)+runLayoutT (LayoutT m) = do+ (a,fps) <- runWriterT $ flip runReaderT Unspecified m+ return (a, Comb Unspecified fps)++renderLayout :: String -> Layout s b a -> IO ()+renderLayout title = renderFloorplan title . snd . runLayout++renderLayoutT+ :: Monad m+ => (forall a . m a -> a)+ -> String -> LayoutT s b m a -> IO ()+renderLayoutT runner title = renderFloorplan title . snd . runner . runLayoutT++++instance MonadTrans (LayoutT s b)+ where+ lift = LayoutT . lift . lift++++space__ :: MonadWriter [Floorplan s b] m => Length -> Maybe s -> m ()+space__ len ms = tell [Block $ Space (Dist len) ms]++block__ :: MonadWriter [Floorplan s b] m => Width -> Height -> Name -> b -> m ()+block__ x y nm b = tell [Block $ Box (x,y) north nm b]++subLayout_+ :: (MonadReader Placement m, MonadWriter [Floorplan s b] m)+ => Placement -> m a -> m a+subLayout_ pl m = local (const pl) $ censor (\fps -> [Comb pl fps]) m++transformFloorplan_+ :: (MonadReader Placement m, MonadWriter [Floorplan s b] m)+ => (Floorplan s b -> Floorplan s b) -> m a -> m a+transformFloorplan_ trans m = do+ pl <- ask+ censor (\fps -> [trans $ Comb pl fps]) m++++class Monad m => MonadLayout s b m | m -> s b+ where+ currentPlacement :: m Placement++ space_ :: Length -> Maybe s -> m ()++ block_ :: Width -> Height -> Name -> b -> m ()++ subLayout :: Placement -> m a -> m a++ transformFloorplan :: (Floorplan s b -> Floorplan s b) -> m a -> m a++instance MonadLayout s b (Layout s b)+ where+ currentPlacement = Layout ask++ space_ len ms = Layout $ space__ len ms++ block_ x y nm b = Layout $ block__ x y nm b++ subLayout pl (Layout m) = Layout $ subLayout_ pl m++ transformFloorplan trans (Layout m) = Layout $ transformFloorplan_ trans m++instance Monad m => MonadLayout s b (LayoutT s b m)+ where+ currentPlacement = LayoutT ask++ space_ len ms = LayoutT $ space__ len ms++ block_ x y nm b = LayoutT $ block__ x y nm b++ subLayout pl (LayoutT m) = LayoutT $ subLayout_ pl m++ transformFloorplan trans (LayoutT m) = LayoutT $ transformFloorplan_ trans m++++space :: MonadLayout s b m => Length -> a -> m a+space len a = space_ len Nothing >> return a++block :: MonadLayout s b m => Width -> Height -> Name -> b -> a -> m a+block x y nm b a = block_ x y nm b >> return a++rightwards, leftwards, upwards, downwards :: MonadLayout s b m => m a -> m a+rightwards = subLayout (Row Rightwards BottomLeft)+leftwards = subLayout (Row Leftwards BottomLeft)+upwards = subLayout (Row Upwards BottomLeft)+downwards = subLayout (Row Downwards BottomLeft)++rightwards', leftwards', upwards', downwards' :: MonadLayout s b m => m a -> m a+rightwards' = subLayout (Row Rightwards TopRight)+leftwards' = subLayout (Row Leftwards TopRight)+upwards' = subLayout (Row Upwards TopRight)+downwards' = subLayout (Row Downwards TopRight)+ -- *** These will not be needed when elastic space has been implemented.++unplaced :: MonadLayout s b m => m a -> m a+unplaced = subLayout Unspecified++stacked :: MonadLayout s b m => m a -> m a+stacked = subLayout (Stack BottomLeft BottomLeft)++translate :: MonadLayout s bl m => Width -> Height -> m a -> m a+translate x y ma = do+ pl <- currentPlacement+ rightwards $ do+ space_ (icast x) Nothing+ upwards $ do+ space_ (icast y) Nothing+ subLayout pl ma++++instance MonadLayout s b m => Transformable (m a)+ where+ flipX = transformFloorplan flipX+ flipY = transformFloorplan flipY+ rotate_ = transformFloorplan . rotate_+
+ Layout/Postscript.hs view
@@ -0,0 +1,404 @@+module Layout.Postscript where++++import Data.String++import Data.Hardware.Internal+import Layout.Floorplan++++type Postscript = ShowS++++class Show a => PSShow a+ where+ psShow :: a -> Postscript++instance PSShow Int+ where+ psShow n = shows n++instance (IsString a, Show a) => PSShow a+ where+ psShow a = "(" .+ shows a .+ ")"++deriving instance PSShow Width+deriving instance PSShow Height++instance PSShow Orientation+ where+ psShow (flipped,dir) = shows (f + d)+ where+ f = if flipped then 4 else 0++ d = case dir of+ Rightwards -> 3+ Leftwards -> 1+ Upwards -> 0+ Downwards -> 2++++absToPS :: AbsFloorplan s b -> Postscript+absToPS [] = ""+absToPS (pos_bl : pos_bls) = absPS pos_bl .+ absToPS pos_bls+ where+ absPS (pos, Box sz ori nm _) = blockLine pos sz ori nm+ absPS _ = id++ blockLine (x,y) (w,h) ori nm+ | w * icast h > 0 = unwordS+ [ psShow x+ , psShow y+ , psShow w+ , psShow h+ , psShow ori+ , psShow nm+ , "block\n"+ ]++++floorplanToPS :: Floorplan s b -> (Postscript, Size)+floorplanToPS fp = (absToPS afp, sz)+ where+ (afp,sz) = absolutize fp++++linesToPS :: [(Position,Position)] -> Postscript+linesToPS [] = id+linesToPS (line:lines)+ = unwordS+ [ psShow x1, psShow y1+ , psShow x2, psShow y2+ , "wire\n"+ ]+ .+ linesToPS lines+ where+ ((x1,y1),(x2,y2)) = line++++renderFloorplan_+ :: Int -> String -> Floorplan s b -> [(Position,Position)] -> IO ()++renderFloorplan_ lnScale title fp lines = writeFile (title ++ ".ps")+ $ "%!PS-Adobe-1.0\n"+ .+ "%%Title: " .+ showString title .+ "\n"+ .+ ps1+ .+ lnScLine+ .+ ps2+ .+ setPicSize sz+ .+ ps3+ .+ ps+ -- .+ "\nshowpage\n"+ -- *** This should make a first page without wires, but it doesn't seem to+ -- work.+ .+ "\nwireWidth setlinewidth\n\n"+ .+ linesToPS lines+ $ "\nshowpage\n"+ where+ (ps,sz) = floorplanToPS fp++ lnScLine+ = shows lnScale+ .+ showString (replicate (6 - length (show lnScale)) ' ')+ .+ "% Scale for lines and names\n"++ setPicSize (x,y) = unlineS+ [ "/picW " .+ shows (toInt x) .+ " def"+ , "/picH " .+ shows (toInt y) .+ " def"+ , " % Width/heigth of picture (in floorplan units)"+ , ""+ ]++ -- The first parameter is the scale for lines and names.++++renderFloorplan :: String -> Floorplan s b -> IO ()+renderFloorplan title fp = renderFloorplan_ 1 title fp []++++ps1 :: Postscript+ps1 =+ "%%DocumentFonts: Helvetica \n\+ \%%BoundingBox: 0 0 595 842 \n\+ \%%EndComments \n\+ \ \n\+ \% The picture is scaled to fit on an A4 paper (see bounding box above). \n\+ \% In order to zoom in on a particular area, just adjust the bounding box \n\+ \% and/or the scale. \n\+ \ \n\+ \ \n\+ \ \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \%%% Setup \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \ \n\+ \true % Print block names? \n\+ \2 % Vertical margin in [mm] \n\+ \2 % Horizontal margin in [mm] \n\+ \15 % Height of block names (~floorplan units) \n\+ \2 % Width of wire lines (in floorplan units) \n\+ \2.5 % Radius of box corners (in floorplan units) \n\+ \2.5 % Line width of primitive blocks (in floorplan units) \n\+ \1 % Overall scale \n"++++ps2 :: Postscript+ps2 =+ " \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \/lnSc exch def %% \n\+ \/sc exch def %% \n\+ \/boxLineWidth exch lnSc mul def %% \n\+ \/boxCornerRad exch lnSc mul def %% \n\+ \/wireWidth exch lnSc mul def %% \n\+ \/namesFontSize exch lnSc mul def %% \n\+ \/margH exch def %% \n\+ \/margV exch def %% \n\+ \/prNames exch def %% \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \ % Bindings in reversed order \n\+ \ \n\+ \/ratio {72 25.4 div} def \n\+ \ % Units/mm \n\+ \ \n\+ \/totW 210 def \n\+ \/totH 297 def \n\+ \ % Width/height of A4 in [mm] \n\+ \ \n\+ \/totWU {totW ratio mul} def \n\+ \/totHU {totH ratio mul} def \n\+ \ % Unit width/height of A4 \n\+ \ \n\+ \/margHU {margH ratio mul} def \n\+ \/margVU {margV ratio mul} def \n\+ \ % Horizontal/vertical margin units \n\+ \ \n\+ \/picWU {totWU margHU 2 mul sub} def \n\+ \/picHU {totHU margVU 2 mul sub} def \n\+ \ % Unit width/height of the picture \n\+ \ \n"++++ps3 :: Postscript+ps3 =+ "/scH {picWU picW div} def \n\+ \/scV {picHU picH div} def \n\+ \scH scV gt {/scHV scV def} {/scHV scH def} ifelse \n\+ \ % Scale necessary to fit picture in the page \n\+ \ \n\+ \margHU margVU translate \n\+ \ \n\+ \sc scHV mul dup scale \n\+ \ \n\+ \/Helvetica findfont \n\+ \namesFontSize scalefont \n\+ \setfont \n\+ \ \n\+ \ \n\+ \ \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \%%% Helper functions \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \ \n\+ \/rectWH { \n\+ \ 2 dict begin \n\+ \ /h exch def \n\+ \ /w exch def \n\+ \ w 0 rlineto \n\+ \ 0 h rlineto \n\+ \ w neg 0 rlineto \n\+ \ closepath \n\+ \ end \n\+ \} def \n\+ \ \n\+ \/rectWH_round { \n\+ \ 10 dict begin \n\+ \ /r exch def \n\+ \ /h exch def \n\+ \ /w exch def \n\+ \ \n\+ \ h boxCornerRad 2 mul lt \n\+ \ w boxCornerRad 2 mul lt or \n\+ \ {w h rectWH} \n\+ \ { /wr {w r sub r sub} def \n\+ \ /hr {h r sub r sub} def \n\+ \ /r2 {r 2 div} def \n\+ \ /rn {r neg} def \n\+ \ /r2n {r2 neg} def \n\+ \ \n\+ \ currentpoint \n\+ \ /y exch def \n\+ \ /x exch def \n\+ \ newpath \n\+ \ x r add y moveto \n\+ \ % Start new path since we cannot start from the lower left corner \n\+ \ \n\+ \ wr 0 rlineto \n\+ \ r2 0 r r2 r r rcurveto \n\+ \ 0 hr rlineto \n\+ \ 0 r2 r2n r rn r rcurveto \n\+ \ wr neg 0 rlineto \n\+ \ r2n 0 rn r2n rn rn rcurveto \n\+ \ 0 hr neg rlineto \n\+ \ 0 r2n r2 rn r rn rcurveto \n\+ \ closepath \n\+ \ } ifelse \n\+ \ \n\+ \ end \n\+ \} def \n\+ \ \n\+ \/block { \n\+ \ 9 dict begin \n\+ \ /name exch def % Block name \n\+ \ /ori exch def % Orientation (0=N,1=W,2=S,3=E,4=FN,5=FW,6=FS,7=FE) \n\+ \ /h exch def % Height \n\+ \ /w exch def % Width \n\+ \ /py exch def % Y position \n\+ \ /px exch def % X position \n\+ \ \n\+ \ /c1 0.4 def \n\+ \ /c2 8 def \n\+ \ /c3 6 def \n\+ \ % Constants for the orientation triangle \n\+ \ \n\+ \ gsave \n\+ \ px py translate \n\+ \ \n\+ \ newpath \n\+ \ 0 0 moveto \n\+ \ w h boxCornerRad rectWH_round \n\+ \ \n\+ \ gsave \n\+ \ 0.75 setgray \n\+ \ fill \n\+ \ grestore \n\+ \ \n\+ \ gsave \n\+ \ newpath \n\+ \ \n\+ \ ori 0 eq \n\+ \ { boxLineWidth c1 mul dup moveto \n\+ \ boxLineWidth c2 mul 0 rlineto \n\+ \ boxLineWidth c3 neg mul boxLineWidth c2 mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 1 eq \n\+ \ { w 0 moveto \n\+ \ boxLineWidth c1 neg mul boxLineWidth c1 mul rmoveto \n\+ \ 0 boxLineWidth c2 mul rlineto \n\+ \ boxLineWidth c2 neg mul boxLineWidth c3 neg mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 2 eq \n\+ \ { w h moveto \n\+ \ boxLineWidth c1 neg mul dup rmoveto \n\+ \ boxLineWidth c2 neg mul 0 rlineto \n\+ \ boxLineWidth c3 mul boxLineWidth c2 neg mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 3 eq \n\+ \ { 0 h moveto \n\+ \ boxLineWidth c1 mul boxLineWidth c1 neg mul rmoveto \n\+ \ 0 boxLineWidth c2 neg mul rlineto \n\+ \ boxLineWidth c2 mul boxLineWidth c3 mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 4 eq \n\+ \ { w 0 moveto \n\+ \ boxLineWidth c1 neg mul boxLineWidth c1 mul rmoveto \n\+ \ boxLineWidth c2 neg mul 0 rlineto \n\+ \ boxLineWidth c3 mul boxLineWidth c2 mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 5 eq \n\+ \ { boxLineWidth c1 mul dup moveto \n\+ \ 0 boxLineWidth c2 mul rlineto \n\+ \ boxLineWidth c2 mul boxLineWidth c3 neg mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 6 eq \n\+ \ { 0 h moveto \n\+ \ boxLineWidth c1 mul boxLineWidth c1 neg mul rmoveto \n\+ \ boxLineWidth c2 mul 0 rlineto \n\+ \ boxLineWidth c3 neg mul boxLineWidth c2 neg mul rlineto \n\+ \ } if \n\+ \ \n\+ \ ori 7 eq \n\+ \ { w h moveto \n\+ \ boxLineWidth c1 neg mul dup rmoveto \n\+ \ 0 boxLineWidth c2 neg mul rlineto \n\+ \ boxLineWidth c2 neg mul boxLineWidth c3 mul rlineto \n\+ \ } if \n\+ \ \n\+ \ closepath \n\+ \ 0.45 0.45 0.3 setrgbcolor \n\+ \ fill \n\+ \ grestore \n\+ \ \n\+ \ gsave \n\+ \ closepath \n\+ \ clip \n\+ \ \n\+ \ prNames { \n\+ \ newpath \n\+ \ 0 0 moveto \n\+ \ boxLineWidth 2 mul boxLineWidth 4 mul rmoveto \n\+ \ name show \n\+ \ stroke \n\+ \ } if \n\+ \ grestore \n\+ \ \n\+ \ gsave \n\+ \ 0.25 setgray \n\+ \ boxLineWidth setlinewidth \n\+ \ stroke \n\+ \ grestore \n\+ \ \n\+ \ grestore \n\+ \ \n\+ \ end \n\+ \} def \n\+ \ \n\+ \/wire { \n\+ \ 4 dict begin \n\+ \ /y2 exch def \n\+ \ /x2 exch def \n\+ \ /y1 exch def \n\+ \ /x1 exch def \n\+ \ \n\+ \ gsave \n\+ \ newpath \n\+ \ x1 y1 moveto \n\+ \ x2 y2 lineto \n\+ \ closepath \n\+ \ stroke \n\+ \ newpath \n\+ \ x1 y1 wireWidth 0 360 arc \n\+ \ closepath \n\+ \ fill \n\+ \ newpath \n\+ \ x2 y2 wireWidth 0 360 arc \n\+ \ closepath \n\+ \ fill \n\+ \ grestore \n\+ \ end \n\+ \} def \n\+ \ \n\+ \ \n\+ \ \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \%%% Draw floorplan \n\+ \%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \n\+ \ \n"+
+ Libs/Simple130nm/Lava.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Libs.Simple130nm.Lava where++++import Data.Hardware.Internal+import Lava.Internal+import Lava++import qualified Lava2000 as L+import qualified Lava2000.Arithmetic as L++++data Simple130nm+ = IVHSP+ | AN2HSP+ | OR2HSP+ | HA1HSP+ | FA1HSP+ deriving (Eq, Show)++++instance CellLibrary Simple130nm+ where+ numConsts _ = 2++ numIns IVHSP = 1+ numIns AN2HSP = 2+ numIns OR2HSP = 2+ numIns HA1HSP = 2+ numIns FA1HSP = 2++ numOuts IVHSP = 1+ numOuts AN2HSP = 1+ numOuts OR2HSP = 1+ numOuts HA1HSP = 2+ numOuts FA1HSP = 2++++ pinName IVHSP 0 = "Z"+ pinName IVHSP 1 = "A"++ pinName AN2HSP 0 = "Z"+ pinName AN2HSP 1 = "A"+ pinName AN2HSP 2 = "B"++ pinName OR2HSP 0 = "Z"+ pinName OR2HSP 1 = "A"+ pinName OR2HSP 2 = "B"++ pinName HA1HSP 0 = "S"+ pinName HA1HSP 1 = "CO"+ pinName HA1HSP 2 = "A"+ pinName HA1HSP 3 = "B"++ pinName FA1HSP 0 = "Z"+ pinName FA1HSP 1 = "CO"+ pinName FA1HSP 2 = "A"+ pinName FA1HSP 3 = "B"+ pinName FA1HSP 4 = "CI"++++ pinId IVHSP "Z" = 0+ pinId IVHSP "A" = 1++ pinId AN2HSP "Z" = 0+ pinId AN2HSP "A" = 1+ pinId AN2HSP "B" = 2++ pinId OR2HSP "Z" = 0+ pinId OR2HSP "A" = 1+ pinId OR2HSP "B" = 2++ pinId HA1HSP "S" = 0+ pinId HA1HSP "CO" = 1+ pinId HA1HSP "A" = 2+ pinId HA1HSP "B" = 3++ pinId FA1HSP "Z" = 0+ pinId FA1HSP "CO" = 1+ pinId FA1HSP "A" = 2+ pinId FA1HSP "B" = 3+ pinId FA1HSP "CI" = 4++++ isFlop = const False++ lava2000Interp = Interp+ { constants = [L.low, L.high]+ , defaultVal = error "Undefined signal"+ , propagator = prop+ }+ where+ prop IVHSP = \[_,a] -> [Just (L.inv a), Nothing]++ prop AN2HSP = \[_,a,b] -> [Just (L.and2 (a,b)), Nothing, Nothing]++ prop OR2HSP = \[_,a,b] -> [Just (L.or2 (a,b)), Nothing, Nothing]++ prop HA1HSP = \[_,_,a,b] ->+ let (s,co) = L.halfAdd (a,b)+ in [Just s, Just co, Nothing, Nothing]++ prop FA1HSP = \[_,_,a,b,ci] ->+ let (s,co) = L.fullAdd (a,(b,ci))+ in [Just s, Just co, Nothing, Nothing]++++low,high :: Signal+[low,high] = libraryConstants (T::TypeOf Simple130nm)++inv :: MonadLava Simple130nm m => Signal -> m Signal+inv = cell IVHSP++and2 :: MonadLava Simple130nm m => (Signal,Signal) -> m Signal+and2 = cell AN2HSP++or2 :: MonadLava Simple130nm m => (Signal,Signal) -> m Signal+or2 = cell OR2HSP++halfAdd :: MonadLava Simple130nm m => (Signal,Signal) -> m (Signal,Signal)+halfAdd = cell HA1HSP++fullAdd :: MonadLava Simple130nm m => (Signal, (Signal,Signal)) -> m (Signal,Signal)+fullAdd = cell FA1HSP+
+ Libs/Simple130nm/Wired.hs view
@@ -0,0 +1,96 @@+module Libs.Simple130nm.Wired+ ( Simple130nm (..)+ , low+ , high+ , rowHeight+ , guideN+ , guideS+ , guideW+ , guideE+ , Libs.Simple130nm.Wired.and2+ , Libs.Simple130nm.Wired.halfAdd+ , Libs.Simple130nm.Wired.fullAdd+ ) where++++import Data.Hardware.Internal+import Lava+import Wired.Model+import Wired+import Libs.Simple130nm.Lava as Lava++++instance WiredLibrary Simple130nm+ where+ lambda = const 65++++rowHeight :: Height+rowHeight = 4920++guideLength :: Length+guideLength = 600 -- To satisfy minimum area of metal segments++++guide_+ :: PortStruct p Signal t+ => Direction -> Layer -> Width -> (p -> Wired Simple130nm p)++guide_ dir lay pitch++ | lay >= 6 = error+ "Libs.Simple130nm.Wired.guide_: Only supporting layers 1-5"+ -- Because layer 6 has different properties.++ | lay==1 = guide dir guideLength 1 pitch++ | Vertical <- directionAngle dir, odd lay = error $+ "Layer " ++ show (toInt lay) ++ " doesn't support vertical wires"++ | Horizontal <- directionAngle dir, even lay = error $+ "Layer " ++ show (toInt lay) ++ " doesn't support horizontal wires"++ | otherwise = guide dir guideLength lay pitch++++guideN, guideS, guideW, guideE+ :: PortStruct p Signal t => Layer -> Width -> (p -> Wired Simple130nm p)++guideN = guide_ Upwards+guideS = guide_ Downwards+guideW = guide_ Leftwards+guideE = guide_ Rightwards++++and2 :: (Signal,Signal) -> Wired Simple130nm Signal+and2 (a,b) = stacked $ do+ guidePos Rightwards 0 1 (1000,2665) a+ guidePos Rightwards 0 1 (1200,2255) b+ mkCell "AN2HSP" 2050 4920 $ Lava.and2 (a,b)+ >>= guidePos Rightwards 0 1 (200,1400)++halfAdd :: (Signal,Signal) -> Wired Simple130nm (Signal,Signal)+halfAdd (a,b) = stacked $ do+ guidePos Rightwards 0 1 (1345,3895) a+ guidePos Rightwards 0 1 (1310,2255) b+ (s,co) <- mkCell "HA1HSP" 4510 4920 $ Lava.halfAdd (a,b)+ guidePos Rightwards 0 1 (4265,1500) s+ guidePos Rightwards 0 1 (205,1500) co+ return (s,co)++fullAdd :: (Signal,(Signal,Signal)) -> Wired Simple130nm (Signal,Signal)+fullAdd (ci,(a,b)) = stacked $ do+ guidePos Rightwards 0 1 (1310,2255) ci+ guidePos Rightwards 0 1 (3800,2255) a+ guidePos Rightwards 0 1 (1500,2665) b+ (z,co) <- mkCell "FA1HSP" 7790 4920 $ Lava.fullAdd (ci,(a,b))+ guidePos Rightwards 0 1 (7560,1500) z+ guidePos Rightwards 0 1 (205,1500) co+ return (z,co)+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Wired.cabal view
@@ -0,0 +1,64 @@+name: Wired+version: 0.1+synopsis: Wire-aware hardware description++description: An extension to the hardware description library Lava+ targeting (not exclusively) semi-custom VLSI design. A+ particular aim of Wired is to give the designer more+ control over the routing wires' effects on performance.++category: Hardware+license: BSD3+license-file: LICENSE+copyright: (c) 2008. Emil Axelsson <emax@chalmers.se>+author: Emil Axelsson <emax@chalmers.se>+maintainer: Emil Axelsson <emax@chalmers.se>+cabal-version: >= 1.2+build-type: Simple+tested-with: GHC ==6.8.3+data-files: Examples/UsingLava.hs, Examples/UsingWired.hs,+ Examples/Sklansky.hs, Examples/Mult.hs++library+ exposed-modules:+ Data.Logical.Knot+ Data.Logical.Let+ Lava+ Layout+ Wired+ Analysis.STA+ Libs.Simple130nm.Lava+ Libs.Simple130nm.Wired++ other-modules:+ Data.Hardware.Internal+ Data.Hardware+ Lava.Model+ Lava.Patterns+ Lava.Loop+ Lava.Port+ Lava.Interpret+ Lava.Internal+ Layout.Floorplan+ Layout.Postscript+ Layout.Internal+ Wired.Model++ build-Depends: base, chalmers-lava2000, containers, mtl, QuickCheck++ extensions:+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ OverlappingInstances+ OverloadedStrings+ PatternGuards+ Rank2Types+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TypeSynonymInstances+ UndecidableInstances+
+ Wired.hs view
@@ -0,0 +1,19 @@+module Wired+ ( module Data.Hardware+ , module Lava+ , module Layout+ , Wired+ , stripLayout+ , renderWired+ , renderWiredWithNets+ ) where++++import Control.Monad++import Data.Hardware+import Lava+import Layout+import Wired.Model+
+ Wired/Model.hs view
@@ -0,0 +1,211 @@+module Wired.Model where++++import Control.Monad.Reader+import Control.Monad.Writer+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.String++import Data.Hardware.Internal+import Lava.Internal+import Layout.Internal++++class CellLibrary lib => WiredLibrary lib+ where+ lambda :: TypeOf lib -> Length+ -- Half feature size++type Guide = (Signal, Layer, Direction, Length)+ -- A roting guide associated with a signal.++type Wired lib = LayoutT Guide CellId (Lava lib)+ -- Each box is associated with a cell. Space may be associated with a guide.++class ( MonadLava lib m+ , WiredLibrary lib+ , MonadLayout Guide CellId m+ )+ => MonadWired lib m++instance ( MonadLava lib m+ , WiredLibrary lib+ , MonadLayout Guide CellId m+ )+ => MonadWired lib m++++runWired+ :: CellLibrary lib+ => Wired lib a -> (a, (DesignDB lib, Floorplan Guide CellId))++runWired w = (a,(ds,fp))+ where+ ((a,fp),ds) = runLava $ runLayoutT w++++stripLayout :: MonadLava lib m => LayoutT s b m a -> m a+stripLayout = liftM fst . runLayoutT++++instance MonadLava lib m => MonadLava lib (LayoutT s b m)+ where+ newPrimInpId = lift newPrimInpId+ newCellId = lift newCellId+ declare = lift . declare++ listenDecls (LayoutT ma) = LayoutT $ do+ pl <- ask+ ((a,fps),decls) <- lift $ lift $+ listenDecls $ runWriterT $ runReaderT ma pl+ tell fps+ return (a,decls)++++convertGuide+ :: (Position, AbsBlock Guide CellId)+ -> (Signal, (Layer,Position,Position))++convertGuide bl = (sig,(lay,pos1,pos2))+ where+ ((x,y), Space _ (Just (sig,lay,dir,len))) = bl++ pos1 = blockCenter bl++ pos2 = case dir of+ Rightwards -> (x + icast len, y)+ Leftwards -> (x - icast len, y)+ Upwards -> (x, y + icast len)+ Downwards -> (x, y - icast len)++++mkGuideDB+ :: Floorplan Guide CellId -> Map Signal [(Layer,Position,Position)]++mkGuideDB fp = Map.fromListWith (++)+ [ (sig,[g])+ | bl@(_, Space _ (Just _)) <- fst $ absolutize fp+ , let (sig,g) = convertGuide bl+ ]+ -- Can be conveniently used with totalLookup.++++renderWired :: forall lib a . WiredLibrary lib => String -> Wired lib a -> IO ()+renderWired title w = renderFloorplan_ lam title fp []+ where+ lam = icast $ lambda (T::TypeOf lib)+ fp = snd $ snd $ runWired w+ -- Lambda is a reasonable scale for lines and names.++++fpToLines :: Floorplan Guide CellId -> [(Position,Position)]+fpToLines fp = concat+ [ rectiSpanning [pos | (_,pos,_) <- guides]+ | (_,guides) <- Map.toList $ mkGuideDB fp+ ]++ -- Returns the lines between the guides in the floorplan. Guides associated+ -- with the same signal end up in the same cluster. This sort of assumes that+ -- the cells have guides marking the position of each of their pins, otherwise+ -- the lines will only include the guides between the cells (if any), and the+ -- cells will look disconnected when drawn.+ --+ -- The guides are treated as single points regardless of their length.++++renderWiredWithNets :: forall lib a .+ WiredLibrary lib => String -> Wired lib a -> IO ()++renderWiredWithNets title w = renderFloorplan_ lam title fp (fpToLines fp)+ where+ lam = icast $ lambda (T::TypeOf lib)+ fp = snd $ snd $ runWired w++++guide+ :: (MonadWired lib m, PortStruct p Signal t)+ => Direction -> Length -> Layer -> Width -> (p -> m p)++guide dir len lay pitch = mapPortM $ \sig -> do+ space_ (icast pitch) (Just (sig,lay,dir,len))+ return sig++++guidePos+ :: (MonadWired lib m, PortStruct p Signal t)+ => Direction -> Length -> Layer -> Position -> (p -> m p)++guidePos dir len lay (x,y) = translate x y . guide dir len lay 0++++mkCell+ :: MonadWired lib m+ => Name+ -> Width+ -> Height+ -> m a+ -> m a++mkCell nm x y ma = do+ (a, [Cell cid _ _]) <- listenDecls ma+ block x y nm cid a++++showOri :: IsString str => Orientation -> str+showOri (flipped,dir) = fromString $+ (if flipped then "F" else "") ++ showDir dir+ where+ showDir Rightwards = "E"+ showDir Leftwards = "W"+ showDir Upwards = "N"+ showDir Downwards = "S"++ -- Uses the notion of orientation from the Cadence DEF format.+ --+ -- .------, .------,+ -- N: | #| FN: |# |+ -- | #| |# |+ -- | | | |+ -- '------' '------'+ --+ -- .------, .------,+ -- S: | | FS: | |+ -- |# | | #|+ -- |# | | #|+ -- '------' '------'+ --+ -- .------, .------,+ -- W: |### | FW: | ###|+ -- | | | |+ -- | | | |+ -- '------' '------'+ --+ -- .------, .------,+ -- E: | | FE: | |+ -- | | | |+ -- | ###| |### |+ -- '------' '------'+ --+ -- So N is the standard orientation and S/W/E are rotations of the standard+ -- orientation. FN/FS/FW/FE are simply flipped around the y-axis.++ -- *** Needed?+