import qualified Maybe
import qualified Control.Arrow as Arrow
import qualified DataCon
+import qualified TyCon
import qualified CoreUtils
+import qualified TysWiredIn
+import qualified IdInfo
import qualified Data.Traversable as Traversable
import qualified Data.Foldable as Foldable
import Control.Applicative
setSignalInfo id' (info { sigUse = f use})
return id'
--- | Duplicate the given signal, assigning its value to the new signal.
--- Returns the new signal id.
-duplicateSignal :: SignalId -> FlattenState SignalId
-duplicateSignal id = do
+-- | Creates a new internal signal with the same type as the given signal
+copySignal :: SignalId -> FlattenState SignalId
+copySignal id = do
-- Find the type of the original signal
info <- getSignalInfo id
let ty = sigTy info
-- Generate a new signal (which is SigInternal for now, that will be
-- sorted out later on).
- id' <- genSignalId SigInternal ty
+ genSignalId SigInternal ty
+
+-- | Duplicate the given signal, assigning its value to the new signal.
+-- Returns the new signal id.
+duplicateSignal :: SignalId -> FlattenState SignalId
+duplicateSignal id = do
+ -- Create a new signal
+ id' <- copySignal id
-- Assign the old signal to the new signal
- addDef $ UncondDef id id'
+ addDef $ UncondDef (Left id) id'
-- Replace the signal with the new signal
return id'
(args, res) <- flattenExpr binds' expr
return (defs : args, res)
-flattenExpr binds (Var id) =
- case bind of
- Left sig_use -> return ([], sig_use)
- Right _ -> error "Higher order functions not supported."
- where
- bind = Maybe.fromMaybe
- (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
- (lookup id binds)
+flattenExpr binds var@(Var id) =
+ case Var.globalIdVarDetails id of
+ IdInfo.NotGlobalId ->
+ let
+ bind = Maybe.fromMaybe
+ (error $ "Local value " ++ Name.getOccString id ++ " is unknown")
+ (lookup id binds)
+ in
+ case bind of
+ 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)
+ otherwise ->
+ error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
flattenExpr binds app@(App _ _) = do
-- Is this a data constructor application?
otherwise ->
-- Normal function application
let ((Var f), args) = collectArgs app in
- flattenApplicationExpr binds (CoreUtils.exprType app) f args
+ let fname = Name.getOccString f in
+ if fname == "fst" || fname == "snd" then do
+ (args', Tuple [a, b]) <- flattenExpr binds (last args)
+ return (args', if fname == "fst" then a else b)
+ else if fname == "patError" then do
+ -- This is essentially don't care, since the program will error out
+ -- here. We'll just define undriven signals here.
+ let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app
+ args <- mapM genSignals argtys
+ res <- genSignals resty
+ return (args, res)
+ else if fname == "==" then do
+ -- Flatten the last two arguments (this skips the type arguments)
+ ([], a) <- flattenExpr binds (last $ init args)
+ ([], b) <- flattenExpr binds (last args)
+ res <- mkEqComparisons a b
+ return ([], res)
+ else
+ flattenApplicationExpr binds (CoreUtils.exprType app) f args
where
+ mkEqComparisons :: SignalMap -> SignalMap -> FlattenState SignalMap
+ mkEqComparisons a b = do
+ let zipped = zipValueMaps a b
+ Traversable.mapM mkEqComparison zipped
+
+ mkEqComparison :: (SignalId, SignalId) -> FlattenState SignalId
+ mkEqComparison (a, b) = do
+ -- Generate a signal to hold our result
+ res <- genSignalId SigInternal TysWiredIn.boolTy
+ addDef (UncondDef (Right $ Eq a b) res)
+ return res
+
flattenBuildTupleExpr binds args = do
-- Flatten each of our args
flat_args <- (State.mapM (flattenExpr binds) args)
flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
-flattenExpr binds expr@(Case (Var v) b _ alts) =
+flattenExpr binds expr@(Case scrut b _ alts) = do
+ -- TODO: Special casing for higher order functions
+ -- Flatten the scrutinee
+ (_, res) <- flattenExpr binds scrut
case alts of
- [alt] -> flattenSingleAltCaseExpr binds v b alt
- otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
+ [alt] -> flattenSingleAltCaseExpr binds res b alt
+ otherwise -> flattenMultipleAltCaseExpr binds res b alts
where
flattenSingleAltCaseExpr ::
BindMap
-- A list of bindings in effect
- -> Var.Var -- The scrutinee
+ -> SignalMap -- The scrutinee
-> CoreBndr -- The binder to bind the scrutinee to
-> CoreAlt -- The single alternative
- -> FlattenState ( [SignalMap], SignalMap)
- -- See expandExpr
- flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
- if not (DataCon.isTupleCon datacon)
+ -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
+
+ flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) =
+ if DataCon.isTupleCon datacon
then
- error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
- else
let
- -- Lookup the scrutinee (which must be a variable bound to a tuple) in
+ -- 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.
- Left (Tuple tuple_sigs) = Maybe.fromMaybe
- (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
- (lookup v binds)
+ 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
+ else
+ if null bind_vars
+ then
+ -- DataAlts without arguments don't need processing
+ -- (flattenMultipleAltCaseExpr will have done this already).
+ flattenExpr binds expr
+ else
+ error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
+ flattenMultipleAltCaseExpr ::
+ BindMap
+ -- A list of bindings in effect
+ -> SignalMap -- The scrutinee
+ -> CoreBndr -- The binder to bind the scrutinee to
+ -> [CoreAlt] -- The alternatives
+ -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
+
+ flattenMultipleAltCaseExpr binds scrut b (a:a':alts) = do
+ (args, res) <- flattenSingleAltCaseExpr binds scrut b a
+ (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)
+ otherwise ->
+ error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
+ where
+ -- Select either the first or second signal map depending on the value
+ -- of the first argument (True == first map, False == second map)
+ mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap
+ mkConditionals boolsigid true false = do
+ let zipped = zipValueMaps true false
+ Traversable.mapM (mkConditional boolsigid) zipped
+
+ mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId
+ mkConditional boolsigid (true, false) = do
+ -- Create a new signal (true and false should be identically typed,
+ -- so it doesn't matter which one we copy).
+ res <- copySignal true
+ addDef (CondDef boolsigid true false res)
+ return res
-
-flattenExpr _ _ = do
- return ([], Tuple [])
+ flattenMultipleAltCaseExpr binds scrut b (a:alts) =
+ flattenSingleAltCaseExpr binds scrut b a
+
+flattenExpr _ expr = do
+ error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
+
+-- | Translates a dataconstructor without arguments to the corresponding
+-- literal.
+dataConToLiteral :: DataCon.DataCon -> FlattenState String
+dataConToLiteral datacon = do
+ let tycon = DataCon.dataConTyCon datacon
+ let tyname = TyCon.tyConName tycon
+ case Name.getOccString tyname of
+ -- 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'"
+ return lit
+ "Bool" -> do
+ let dcname = DataCon.dataConName datacon
+ let lit = case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+ return lit
+ otherwise ->
+ error $ "Literals of type " ++ (Name.getOccString tyname) ++ " not supported."
appToHsFunction ::
Type.Type -- ^ The return type
projects / matthijs / master-project / cλash.git / blobdiff