module Flatten where
import CoreSyn
-import Control.Monad
+import qualified Control.Monad as Monad
import qualified Var
import qualified Type
import qualified Name
let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
-- Create signal names for the binder
defs <- genSignals arg_ty
+ -- Add name hints to the generated signals
+ let binder_name = Name.getOccString b
+ Traversable.mapM (addNameHint binder_name) defs
let binds' = (b, Left defs):binds
(args, res) <- flattenExpr binds' expr
return (defs : args, res)
Left sig_use -> return ([], sig_use)
Right _ -> error "Higher order functions not supported."
IdInfo.DataConWorkId datacon -> do
- lit <- dataConToLiteral datacon
- let ty = CoreUtils.exprType var
- id <- genSignalId SigInternal ty
- addDef (UncondDef (Right $ Literal lit) id)
- return ([], Single id)
+ if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon)
+ then do
+ -- Empty tuple construction
+ return ([], Tuple [])
+ else do
+ lit <- dataConToLiteral datacon
+ let ty = CoreUtils.exprType var
+ sig_id <- genSignalId SigInternal ty
+ -- Add a name hint to the signal
+ addNameHint (Name.getOccString id) sig_id
+ addDef (UncondDef (Right $ Literal lit) sig_id)
+ return ([], Single sig_id)
otherwise ->
error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app
args <- mapM genSignals argtys
res <- genSignals resty
+ mapM (Traversable.mapM (addNameHint "NC")) args
+ Traversable.mapM (addNameHint "NC") res
return (args, res)
else if fname == "==" then do
-- Flatten the last two arguments (this skips the type arguments)
mkEqComparison (a, b) = do
-- Generate a signal to hold our result
res <- genSignalId SigInternal TysWiredIn.boolTy
+ -- Add a name hint to the signal
+ addNameHint ("s" ++ show a ++ "_eq_s" ++ show b) res
addDef (UncondDef (Right $ Eq a b) res)
return res
let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
-- Generate signals for our result
res <- genSignals ty
+ -- Add name hints to the generated signals
+ let resname = Name.getOccString f ++ "_res"
+ Traversable.mapM (addNameHint resname) res
-- Create the function application
let app = FApp {
appFunc = func,
if not (null b_args)
then
error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
- else
- let binds' = (b, Left b_res) : binds in
+ else do
+ let binds' = (b, Left b_res) : binds
+ -- Add name hints to the generated signals
+ let binder_name = Name.getOccString b
+ Traversable.mapM (addNameHint binder_name) b_res
flattenExpr binds' expr
flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
-- Flatten the scrutinee
(_, res) <- flattenExpr binds scrut
case alts of
+ -- TODO include b in the binds list
[alt] -> flattenSingleAltCaseExpr binds res b alt
- otherwise -> flattenMultipleAltCaseExpr binds res b alts
+ -- Reverse the alternatives, so the __DEFAULT alternative ends up last
+ otherwise -> flattenMultipleAltCaseExpr binds res b (reverse alts)
where
flattenSingleAltCaseExpr ::
BindMap
flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) =
if DataCon.isTupleCon datacon
- then
- let
- -- Unpack the scrutinee (which must be a variable bound to a tuple) in
- -- the existing bindings list and get the portname map for each of
- -- it's elements.
- Tuple tuple_sigs = scrut
- -- TODO include b in the binds list
- -- Merge our existing binds with the new binds.
- binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
- in
- -- Expand the expression with the new binds list
- flattenExpr binds' expr
+ then do
+ -- Unpack the scrutinee (which must be a variable bound to a tuple) in
+ -- the existing bindings list and get the portname map for each of
+ -- it's elements.
+ let Tuple tuple_sigs = scrut
+ -- Add name hints to the returned signals
+ let binder_name = Name.getOccString b
+ Monad.zipWithM (\name sigs -> Traversable.mapM (addNameHint $ Name.getOccString name) sigs) bind_vars tuple_sigs
+ -- Merge our existing binds with the new binds.
+ let binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
+ -- Expand the expression with the new binds list
+ flattenExpr binds' expr
else
if null bind_vars
then
flattenExpr binds expr
else
error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
+
+ flattenSingleAltCaseExpr binds _ _ alt@(DEFAULT, [], expr) =
+ flattenExpr binds expr
+
flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
flattenMultipleAltCaseExpr ::
(args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts)
case a of
(DataAlt datacon, bind_vars, expr) -> do
- lit <- dataConToLiteral datacon
- -- The scrutinee must be a single signal
- let Single sig = scrut
- -- Create a signal that contains a boolean
- boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
- let expr = EqLit sig lit
- addDef (UncondDef (Right expr) boolsigid)
- -- Create conditional assignments of either args/res or
- -- args'/res based on boolsigid, and return the result.
- our_args <- zipWithM (mkConditionals boolsigid) args args'
- our_res <- mkConditionals boolsigid res res'
- return (our_args, our_res)
+ if isDontCare datacon
+ then do
+ -- Completely skip the dontcare cases
+ return (args', res')
+ else do
+ lit <- dataConToLiteral datacon
+ -- The scrutinee must be a single signal
+ let Single sig = scrut
+ -- Create a signal that contains a boolean
+ boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
+ addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid
+ let expr = EqLit sig lit
+ addDef (UncondDef (Right expr) boolsigid)
+ -- Create conditional assignments of either args/res or
+ -- args'/res based on boolsigid, and return the result.
+ -- TODO: It seems this adds the name hint twice?
+ our_args <- Monad.zipWithM (mkConditionals boolsigid) args args'
+ our_res <- mkConditionals boolsigid res res'
+ return (our_args, our_res)
otherwise ->
error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
where
flattenExpr _ expr = do
error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
+-- | Is the given data constructor a dontcare?
+isDontCare :: DataCon.DataCon -> Bool
+isDontCare datacon =
+ case Name.getOccString tyname of
+ -- TODO: Do something more robust than string matching
+ "Bit" ->
+ Name.getOccString dcname == "DontCare"
+ otherwise ->
+ False
+ where
+ tycon = DataCon.dataConTyCon datacon
+ tyname = TyCon.tyConName tycon
+ dcname = DataCon.dataConName datacon
+
-- | Translates a dataconstructor without arguments to the corresponding
-- literal.
dataConToLiteral :: DataCon.DataCon -> FlattenState String
-- TODO: Do something more robust than string matching
"Bit" -> do
let dcname = DataCon.dataConName datacon
- let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+ let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"; "DontCare" -> "'-'"
return lit
"Bool" -> do
let dcname = DataCon.dataConName datacon
projects / matthijs / master-project / cλash.git / blobdiff