diff --git a/Analysis/STA.hs b/Analysis/STA.hs new file mode 100644 --- /dev/null +++ b/Analysis/STA.hs @@ -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. + diff --git a/Data/Hardware.hs b/Data/Hardware.hs new file mode 100644 --- /dev/null +++ b/Data/Hardware.hs @@ -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 + diff --git a/Data/Hardware/Internal.hs b/Data/Hardware/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Hardware/Internal.hs @@ -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 + diff --git a/Data/Logical/Knot.hs b/Data/Logical/Knot.hs new file mode 100644 --- /dev/null +++ b/Data/Logical/Knot.hs @@ -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") + diff --git a/Data/Logical/Let.hs b/Data/Logical/Let.hs new file mode 100644 --- /dev/null +++ b/Data/Logical/Let.hs @@ -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 + diff --git a/Examples/Mult.hs b/Examples/Mult.hs new file mode 100644 --- /dev/null +++ b/Examples/Mult.hs @@ -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 + diff --git a/Examples/Sklansky.hs b/Examples/Sklansky.hs new file mode 100644 --- /dev/null +++ b/Examples/Sklansky.hs @@ -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] + diff --git a/Examples/UsingLava.hs b/Examples/UsingLava.hs new file mode 100644 --- /dev/null +++ b/Examples/UsingLava.hs @@ -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. + diff --git a/Examples/UsingWired.hs b/Examples/UsingWired.hs new file mode 100644 --- /dev/null +++ b/Examples/UsingWired.hs @@ -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. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Lava.hs b/Lava.hs new file mode 100644 --- /dev/null +++ b/Lava.hs @@ -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 + diff --git a/Lava/Internal.hs b/Lava/Internal.hs new file mode 100644 --- /dev/null +++ b/Lava/Internal.hs @@ -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 + diff --git a/Lava/Interpret.hs b/Lava/Interpret.hs new file mode 100644 --- /dev/null +++ b/Lava/Interpret.hs @@ -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 + diff --git a/Lava/Loop.hs b/Lava/Loop.hs new file mode 100644 --- /dev/null +++ b/Lava/Loop.hs @@ -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 + diff --git a/Lava/Model.hs b/Lava/Model.hs new file mode 100644 --- /dev/null +++ b/Lava/Model.hs @@ -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) + diff --git a/Lava/Patterns.hs b/Lava/Patterns.hs new file mode 100644 --- /dev/null +++ b/Lava/Patterns.hs @@ -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 + diff --git a/Lava/Port.hs b/Lava/Port.hs new file mode 100644 --- /dev/null +++ b/Lava/Port.hs @@ -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. + diff --git a/Layout.hs b/Layout.hs new file mode 100644 --- /dev/null +++ b/Layout.hs @@ -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 + diff --git a/Layout/Floorplan.hs b/Layout/Floorplan.hs new file mode 100644 --- /dev/null +++ b/Layout/Floorplan.hs @@ -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) + diff --git a/Layout/Internal.hs b/Layout/Internal.hs new file mode 100644 --- /dev/null +++ b/Layout/Internal.hs @@ -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_ + diff --git a/Layout/Postscript.hs b/Layout/Postscript.hs new file mode 100644 --- /dev/null +++ b/Layout/Postscript.hs @@ -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" + diff --git a/Libs/Simple130nm/Lava.hs b/Libs/Simple130nm/Lava.hs new file mode 100644 --- /dev/null +++ b/Libs/Simple130nm/Lava.hs @@ -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 + diff --git a/Libs/Simple130nm/Wired.hs b/Libs/Simple130nm/Wired.hs new file mode 100644 --- /dev/null +++ b/Libs/Simple130nm/Wired.hs @@ -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) + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Wired.cabal b/Wired.cabal new file mode 100644 --- /dev/null +++ b/Wired.cabal @@ -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 +author: Emil Axelsson +maintainer: Emil Axelsson +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 + diff --git a/Wired.hs b/Wired.hs new file mode 100644 --- /dev/null +++ b/Wired.hs @@ -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 + diff --git a/Wired/Model.hs b/Wired/Model.hs new file mode 100644 --- /dev/null +++ b/Wired/Model.hs @@ -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? +