From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Fri, 19 Jun 2009 11:25:24 +0000 (+0200)
Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;ds=inline;h=8a17f35807fb35ee4d2a4c35c75e1cf99066f94d;hp=-c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project

* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Add another higher order testcase, highordtest2.
  Support VHDL generation for two-alternative cases.

Conflicts:
	Translator.hs
---

8a17f35807fb35ee4d2a4c35c75e1cf99066f94d
diff --combined Adders.hs
index ebc1c8c,d4dbbf8..4b18e39
--- a/Adders.hs
+++ b/Adders.hs
@@@ -1,42 -1,36 +1,42 @@@
  module Adders where
  import Bits
  import qualified Sim
 +
 +import qualified Prelude as P
 +import Prelude hiding (
 +  null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
 +  zipWith, zip, unzip, concat, reverse, iterate )
 +
  import Language.Haskell.Syntax
 -import qualified Data.TypeLevel as TypeLevel
 -import qualified Data.Param.FSVec as FSVec
 +import Types
 +import Data.Param.TFVec
  
 -mainIO f = Sim.simulateIO (Sim.stateless f) ()
 +-- mainIO f = Sim.simulateIO (Sim.stateless f) ()
  
  -- This function is from Sim.hs, but we redefine it here so it can get inlined
  -- by default.
 -stateless :: (i -> o) -> (i -> () -> ((), o))
 -stateless f = \i s -> (s, f i)
 -
 -show_add f = do print ("Sum:   " ++ (displaysigs s)); print ("Carry: " ++ (displaysig c))
 -  where
 -    a = [High, High, High, High]
 -    b = [Low, Low, Low, High]
 -    (s, c) = f (a, b)
 -
 -mux2 :: Bit -> (Bit, Bit) -> Bit
 -mux2 Low (a, b) = a
 -mux2 High (a, b) = b
 +-- stateless :: (i -> o) -> (i -> () -> ((), o))
 +-- stateless f = \i s -> (s, f i)
 +-- 
 +-- show_add f = do print ("Sum:   " ++ (displaysigs s)); print ("Carry: " ++ (displaysig c))
 +--   where
 +--     a = [High, High, High, High]
 +--     b = [Low, Low, Low, High]
 +--     (s, c) = f (a, b)
 +-- 
 +-- mux2 :: Bit -> (Bit, Bit) -> Bit
 +-- mux2 Low (a, b) = a
 +-- mux2 High (a, b) = b
  
  -- Not really an adder, but this is nice minimal hardware description
 -wire :: Bit -> Bit
 -wire a = a
 +-- wire :: Bit -> Bit
 +-- wire a = a
  
 -bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
 -bus v = v
 -
 -bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
 -bus_4 v = v
 +-- bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
 +-- bus v = v
 +-- 
 +-- bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
 +-- bus_4 v = v
  
  {-
  inv_n :: (Pos len) => BitVec len -> BitVec len
@@@ -58,122 -52,129 +58,132 @@@ instance Inv (BitVec D0) wher
    inv_n_rec v = v
  -}
  -- Not really an adder either, but a slightly more complex example
 -inv :: Bit -> Bit
 -inv a = let r = hwnot a in r
 +-- inv :: Bit -> Bit
 +-- inv a = let r = hwnot a in r
  
  -- Not really an adder either, but a slightly more complex example
 -invinv :: Bit -> Bit
 -invinv a = hwnot (hwnot a)
 +-- invinv :: Bit -> Bit
 +-- invinv a = hwnot (hwnot a)
  
  -- Not really an adder either, but a slightly more complex example
 -dup :: Bit -> (Bit, Bit)
 -dup a = (a, a)
 +-- dup :: Bit -> (Bit, Bit)
 +-- dup a = (a, a)
  
  -- Not really an adder either, but a simple stateful example (D-flipflop)
 -dff :: Bit -> Bit -> (Bit, Bit)
 -dff d s = (s', q)
 -  where
 -    q = s
 -    s' = d
 -
 -type ShifterState = (Bit, Bit, Bit, Bit)
 -shifter :: Bit -> ShifterState -> (ShifterState, Bit)
 -shifter i (a, b, c, d) =
 -  (s', d)
 -  where
 -    s' = (i, a, b, c)
 -
 -{-# NOINLINE shifter_en #-}
 -shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
 -shifter_en High i (a, b, c, d) =
 -  (s', d)
 -  where
 -    s' = (i, a, b, c)
 -
 -shifter_en Low i s@(a, b, c, d) =
 -  (s, d)
 +-- dff :: Bit -> Bit -> (Bit, Bit)
 +-- dff d s = (s', q)
 +--   where
 +--     q = s
 +--     s' = d
 +-- 
 +-- type ShifterState = (Bit, Bit, Bit, Bit)
 +-- shifter :: Bit -> ShifterState -> (ShifterState, Bit)
 +-- shifter i (a, b, c, d) =
 +--   (s', d)
 +--   where
 +--     s' = (i, a, b, c)
 +-- 
 +-- {-# NOINLINE shifter_en #-}
 +-- shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
 +-- shifter_en High i (a, b, c, d) =
 +--   (s', d)
 +--   where
 +--     s' = (i, a, b, c)
 +-- 
 +-- shifter_en Low i s@(a, b, c, d) =
 +--   (s, d)
  
  -- Two multiplexed shifters
 -type ShiftersState = (ShifterState, ShifterState)
 -shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
 -shifters sel i (sa, sb) =
 -  (s', out)
 -  where
 -    (sa', outa) = shifter_en sel i sa
 -    (sb', outb) = shifter_en (hwnot sel) i sb
 -    s' = (sa', sb')
 -    out = if sel == High then outa else outb
 +-- type ShiftersState = (ShifterState, ShifterState)
 +-- shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
 +-- shifters sel i (sa, sb) =
 +--   (s', out)
 +--   where
 +--     (sa', outa) = shifter_en sel i sa
 +--     (sb', outb) = shifter_en (hwnot sel) i sb
 +--     s' = (sa', sb')
 +--     out = if sel == High then outa else outb
  
  -- Combinatoric stateless no-carry adder
  -- A -> B -> S
 -no_carry_adder :: (Bit, Bit) -> Bit
 -no_carry_adder (a, b) = a `hwxor` b
 +-- no_carry_adder :: (Bit, Bit) -> Bit
 +-- no_carry_adder (a, b) = a `hwxor` b
  
  -- Combinatoric stateless half adder
  -- A -> B -> (S, C)
 -half_adder :: (Bit, Bit) -> (Bit, Bit)
 -{-# NOINLINE half_adder #-}
 -half_adder (a, b) = 
 -  ( a `hwxor` b, a `hwand` b )
 +-- half_adder :: (Bit, Bit) -> (Bit, Bit)
 +-- {-# NOINLINE half_adder #-}
 +-- half_adder (a, b) = 
 +--   ( a `hwxor` b, a `hwand` b )
  
  -- Combinatoric stateless full adder
  -- (A, B, C) -> (S, C)
 -full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
 -full_adder (a, b, cin) = (s, c)
 -  where
 -    (s1, c1) = half_adder(a, b)
 -    (s, c2)  = half_adder(s1, cin)
 -    c        = c1 `hwor` c2
 -
 -sfull_adder = stateless full_adder
 +-- full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
 +-- full_adder (a, b, cin) = (s, c)
 +--   where
 +--     (s1, c1) = half_adder(a, b)
 +--     (s, c2)  = half_adder(s1, cin)
 +--     c        = c1 `hwor` c2
 +-- 
 +-- sfull_adder = stateless full_adder
  
  -- Four bit adder
  -- Explicit version
  -- [a] -> [b] -> ([s], cout)
 -exp_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
 -
 -exp_adder ([a3,a2,a1,a0], [b3,b2,b1,b0]) =
 -  ([s3, s2, s1, s0], c3)
 -  where
 -    (s0, c0) = full_adder (a0, b0, Low)
 -    (s1, c1) = full_adder (a1, b1, c0)
 -    (s2, c2) = full_adder (a2, b2, c1)
 -    (s3, c3) = full_adder (a3, b3, c2)
 +-- exp_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
 +-- 
 +-- exp_adder ([a3,a2,a1,a0], [b3,b2,b1,b0]) =
 +--   ([s3, s2, s1, s0], c3)
 +--   where
 +--     (s0, c0) = full_adder (a0, b0, Low)
 +--     (s1, c1) = full_adder (a1, b1, c0)
 +--     (s2, c2) = full_adder (a2, b2, c1)
 +--     (s3, c3) = full_adder (a3, b3, c2)
  
  -- Any number of bits adder
  -- Recursive version
  -- [a] -> [b] -> ([s], cout)
 -rec_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
 -
 -rec_adder ([], []) = ([], Low)
 -rec_adder ((a:as), (b:bs)) = 
 -  (s : rest, cout)
 -  where
 -    (rest, cin) = rec_adder (as, bs)
 -    (s, cout) = full_adder (a, b, cin)
 -
 -foo = id
 -add, sub :: Int -> Int -> Int
 -add a b = a + b
 -sub a b = a - b
 -
 -highordtest = \x ->
 -  let s = foo x
 -  in
 -     case s of
 -       (a, b) ->
 -         case a of
 -           High -> add
 -           Low -> let
 -             op' = case b of
 -                High -> sub
 -                Low -> \c d -> c
 -             in
 -                \c d -> op' d c
 +-- rec_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
 +-- 
 +-- rec_adder ([], []) = ([], Low)
 +-- rec_adder ((a:as), (b:bs)) = 
 +--   (s : rest, cout)
 +--   where
 +--     (rest, cin) = rec_adder (as, bs)
 +--     (s, cout) = full_adder (a, b, cin)
 +-- 
 +-- foo = id
 +-- add, sub :: Int -> Int -> Int
 +-- add a b = a + b
 +-- sub a b = a - b
 +-- 
 +-- highordtest = \x ->
 +--   let s = foo x
 +--   in
 +--      case s of
 +--        (a, b) ->
 +--          case a of
 +--            High -> add
 +--            Low -> let
 +--              op' = case b of
 +--                 High -> sub
 +--                 Low -> \c d -> c
 +--              in
 +--                 \c d -> op' d c
 +
 +functiontest :: TFVec D4 Bit -> Bit
 +functiontest = \v -> let r = head v in r
  
+ highordtest2 = \a b ->
+          case a of
+            High -> \c d -> d
+            Low -> let
+              op' :: Bit -> Bit -> Bit
+              op' = case b of
+                 High -> \c d -> d
+                 Low -> \c d -> c
+              in
+                 \c d -> op' d c
  -- Four bit adder, using the continous adder below
  -- [a] -> [b] -> ([s], cout)
  --con_adder_4 as bs = 
diff --combined Translator.hs
index 0f60277,7b548e7..1786332
--- a/Translator.hs
+++ b/Translator.hs
@@@ -52,8 -52,8 +52,8 @@@ import FlattenType
  import VHDLTypes
  import qualified VHDL
  
- -- main = do
- --   makeVHDL "Alu.hs" "exec" True
+ main = do
+   makeVHDL "Adders.hs" "highordtest2" True
  
  makeVHDL :: String -> String -> Bool -> IO ()
  makeVHDL filename name stateful = do
@@@ -62,7 -62,7 +62,7 @@@
    -- Translate to VHDL
    vhdl <- moduleToVHDL core [(name, stateful)]
    -- Write VHDL to file
 -  let dir = "../vhdl/vhdl/" ++ name ++ "/"
 +  let dir = "./vhdl/" ++ name ++ "/"
    mapM (writeVHDL dir) vhdl
    return ()
  
diff --combined VHDL.hs
index 319b5b7,7610231..8eb130f
--- a/VHDL.hs
+++ b/VHDL.hs
@@@ -22,12 -22,13 +22,13 @@@ import Debug.Trac
  import qualified ForSyDe.Backend.VHDL.AST as AST
  
  -- GHC API
+ import CoreSyn
  import qualified Type
  import qualified Name
  import qualified OccName
  import qualified Var
  import qualified TyCon
- import qualified CoreSyn
+ import qualified DataCon
  import Outputable ( showSDoc, ppr )
  
  -- Local imports
@@@ -38,9 -39,6 +39,9 @@@ import TranslatorType
  import HsValueMap
  import Pretty
  import CoreTools
 +import Constants
 +import Generate
 +import GlobalNameTable
  
  createDesignFiles ::
    [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
@@@ -51,7 -49,7 +52,7 @@@ createDesignFiles binds 
    map (Arrow.second $ AST.DesignFile full_context) units
    
    where
 -    init_session = VHDLSession Map.empty builtin_funcs
 +    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
      (units, final_session) = 
        State.runState (createLibraryUnits binds) init_session
      ty_decls = Map.elems (final_session ^. vsTypes)
@@@ -112,7 -110,7 +113,7 @@@ createEntity (fname, expr) = d
        CoreSyn.CoreBndr 
        -> VHDLState VHDLSignalMapElement
      -- We only need the vsTypes element from the state
 -    mkMap = MonadState.lift vsTypes . (\bndr ->
 +    mkMap = (\bndr ->
        let
          --info = Maybe.fromMaybe
          --  (error $ "Signal not found in the name map? This should not happen!")
@@@ -194,7 -192,7 +195,7 @@@ createArchitecture (fname, expr) = d
      procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
      procs' = map AST.CSPSm procs
      -- mkSigDec only uses vsTypes from the state
 -    mkSigDec' = MonadState.lift vsTypes . mkSigDec
 +    mkSigDec' = mkSigDec
  
  -- | Looks up all pairs of old state, new state signals, together with
  --   the state id they represent.
@@@ -223,7 -221,7 +224,7 @@@ mkStateProcSm (num, old, new) 
      rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
      statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
  
 -mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
 +mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
  mkSigDec bndr =
    if True then do --isInternalSigUse use || isStateSigUse use then do
      type_mark <- vhdl_ty $ Var.varType bndr
@@@ -246,38 -244,69 +247,82 @@@ mkConcSm :
  
  mkConcSm (bndr, app@(CoreSyn.App _ _))= do
    signatures <- getA vsSignatures
 -  let 
 -      (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 -      signature = Maybe.fromMaybe
 -          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
 +  funSignatures <- getA vsNameTable
 +  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 +  case (Map.lookup (bndrToString f) funSignatures) of
 +    Just funSignature ->
 +      let
 +        sigs = map (bndrToString.varBndr) args
 +        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
 +        func = (snd funSignature) sigsNames
 +        src_wform = AST.Wform [AST.WformElem func Nothing]
 +        dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
 +        assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 +      in
 +        return $ AST.CSSASm assign
 +    Nothing ->
 +      let  
 +        signature = Maybe.fromMaybe 
 +          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
            (Map.lookup (bndrToString f) signatures)
 -      entity_id = ent_id signature
 -      label = bndrToString bndr
 +        entity_id = ent_id signature
 +        label = bndrToString bndr
        -- Add a clk port if we have state
        --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
        --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 -      portmaps = mkAssocElems args bndr signature
 -    in
 -      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 +        portmaps = mkAssocElems args bndr signature
 +      in
 +        return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
  
  -- GHC generates some funny "r = r" bindings in let statements before
  -- simplification. This outputs some dummy ConcSM for these, so things will at
  -- least compile for now.
  mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
  
+ -- A single alt case must be a selector
+ mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+ 
+ -- Multiple case alt are be conditional assignments and have only wild
+ -- binders in the alts and only variables in the case values and a variable
+ -- for a scrutinee. We check the constructor of the second alt, since the
+ -- first is the default case, if there is any.
+ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
+   let
+     cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+     true_expr  = (varToVHDLExpr true)
+     false_expr  = (varToVHDLExpr false)
+     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+     whenelse = AST.WhenElse true_wform cond_expr
+     dst_name  = AST.NSimple (bndrToVHDLId bndr)
+     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+   in
+     return $ AST.CSSASm assign
+ mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
+ mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
+ 
+ -- Turn a variable reference into a AST expression
+ varToVHDLExpr :: Var.Var -> AST.Expr
+ varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+ 
+ -- Turn a constructor into an AST expression. For dataconstructors, this is
+ -- only the constructor itself, not any arguments it has. Should not be called
+ -- with a DEFAULT constructor.
+ conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+ conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+   where
+     tycon = DataCon.dataConTyCon dc
+     tyname = TyCon.tyConName tycon
+     dcname = DataCon.dataConName dc
+     lit = case Name.getOccString tyname of
+       -- TODO: Do something more robust than string matching
+       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+ conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+ conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+ 
+ 
+ 
  {-
  mkConcSm sigs (UncondDef src dst) _ = do
    src_expr <- vhdl_expr src
@@@ -297,7 -326,7 +342,7 @@@
            -- Create a cast expression, which is just a function call using the
            -- type name as the function name.
            let litexpr = AST.PrimLit lit
 -          ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
 +          ty_id <- vhdl_ty ty
            let ty_name = AST.NSimple ty_id
            let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
            return $ AST.PrimFCall $ AST.FCall ty_name args
@@@ -377,9 -406,9 +422,9 @@@ std_logic_ty :: AST.TypeMar
  std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
  
  -- Translate a Haskell type to a VHDL type
 -vhdl_ty :: Type.Type -> TypeState AST.TypeMark
 +vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
  vhdl_ty ty = do
 -  typemap <- State.get
 +  typemap <- getA vsTypes
    let builtin_ty = do -- See if this is a tycon and lookup its name
          (tycon, args) <- Type.splitTyConApp_maybe ty
          let name = Name.getOccString (TyCon.tyConName tycon)
@@@ -396,7 -425,7 +441,7 @@@
              (tycon, args) <- Type.splitTyConApp_maybe ty
              let name = Name.getOccString (TyCon.tyConName tycon)
              case name of
 -              "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
 +              "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
                "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
                otherwise -> Nothing
        -- Return new_ty when a new type was successfully created
@@@ -408,7 -437,7 +453,7 @@@
  mk_vector_ty ::
    Int -- ^ The length of the vector
    -> Type.Type -- ^ The Haskell type to create a VHDL type for
 -  -> TypeState AST.TypeMark -- The typemark created.
 +  -> VHDLState AST.TypeMark -- The typemark created.
  
  mk_vector_ty len ty = do
    -- Assume there is a single type argument
@@@ -418,9 -447,7 +463,9 @@@
    let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
    let ty_dec = AST.TypeDec ty_id ty_def
    -- TODO: Check name uniqueness
 -  State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
 +  --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
 +  modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
 +  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
    return ty_id