import qualified Maybe
import qualified Control.Arrow as Arrow
import qualified DataCon
+import qualified TyCon
import qualified CoreUtils
+import qualified TysWiredIn
import qualified Data.Traversable as Traversable
import qualified Data.Foldable as Foldable
import Control.Applicative
flattenFunction _ (Rec _) = error "Recursive binders not supported"
flattenFunction hsfunc bind@(NonRec var expr) =
- FlatFunction args res defs sigs''''
+ FlatFunction args res defs sigs
where
init_state = ([], [], 0)
- (fres, end_state) = State.runState (flattenExpr [] expr) init_state
+ (fres, end_state) = State.runState (flattenTopExpr hsfunc expr) init_state
(defs, sigs, _) = end_state
(args, res) = fres
- arg_ports = concat (map Foldable.toList args)
- res_ports = Foldable.toList res
- -- Mark args and result signals as input and output ports resp.
- sigs' = fmap (markSignals SigPortIn arg_ports) sigs
- sigs'' = fmap (markSignals SigPortOut res_ports) sigs'
- -- Mark args and result states as old and new state resp.
- args_states = concat $ zipWith stateList (hsFuncArgs hsfunc) args
- sigs''' = foldl (\s (num, id) -> map (markSignal (SigStateOld num) id) s) sigs'' args_states
- res_states = stateList (hsFuncRes hsfunc) res
- sigs'''' = foldl (\s (num, id) -> map (markSignal (SigStateNew num) id) s) sigs''' res_states
+flattenTopExpr ::
+ HsFunction
+ -> CoreExpr
+ -> FlattenState ([SignalMap], SignalMap)
+
+flattenTopExpr hsfunc expr = do
+ -- Flatten the expression
+ (args, res) <- flattenExpr [] expr
+
+ -- Join the signal ids and uses together
+ let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+ let zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+ -- Set the signal uses for each argument / result, possibly updating
+ -- argument or result signals.
+ args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args
+ res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res
+ return (args', res')
+ where
+ args_use Port = SigPortIn
+ args_use (State n) = SigStateOld n
+ res_use Port = SigPortOut
+ res_use (State n) = SigStateNew n
+
+
+hsUseToSigUse ::
+ (HsValueUse -> SigUse) -- ^ A function to actually map the use value
+ -> (SignalId, HsValueUse) -- ^ The signal to look at and its use
+ -> FlattenState SignalId -- ^ The resulting signal. This is probably the
+ -- same as the input, but it could be different.
+hsUseToSigUse f (id, use) = do
+ info <- getSignalInfo id
+ id' <- case sigUse info of
+ -- Internal signals can be marked as different uses freely.
+ SigInternal -> do
+ return id
+ -- Signals that already have another use, must be duplicated before
+ -- marking. This prevents signals mapping to the same input or output
+ -- port or state variables and ports overlapping, etc.
+ otherwise -> do
+ duplicateSignal id
+ setSignalInfo id' (info { sigUse = f use})
+ return id'
+
+-- | 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).
+ 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 (Left id) id'
+ -- Replace the signal with the new signal
+ return id'
+
flattenExpr ::
BindMap
-> CoreExpr
flattenExpr binds expr@(Case (Var v) b _ alts) =
case alts of
- [alt] -> flattenSingleAltCaseExpr binds v b alt
- otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
+ [alt] -> flattenSingleAltCaseExpr binds var b alt
+ otherwise -> flattenMultipleAltCaseExpr binds var b alts
where
+ var = Maybe.fromMaybe
+ (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
+ (lookup v binds)
+
flattenSingleAltCaseExpr ::
BindMap
-- A list of bindings in effect
- -> Var.Var -- The scrutinee
+ -> BindValue -- 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 var 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)
+ Left (Tuple tuple_sigs) = var
-- 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
+ -> BindValue -- The scrutinee
+ -> CoreBndr -- The binder to bind the scrutinee to
+ -> [CoreAlt] -- The alternatives
+ -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
+
+ flattenMultipleAltCaseExpr binds var b (a:a':alts) = do
+ (args, res) <- flattenSingleAltCaseExpr binds var b a
+ (args', res') <- flattenMultipleAltCaseExpr binds var b (a':alts)
+ case a of
+ (DataAlt datacon, bind_vars, expr) -> 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
+ -- The scrutinee must be a single signal
+ let Left (Single sig) = var
+ let dcname = DataCon.dataConName datacon
+ let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+ -- 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 $ "Type " ++ (Name.getOccString tyname) ++ " not supported in multiple alternative case expressions."
+ 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
+
+ flattenMultipleAltCaseExpr binds var b (a:alts) =
+ flattenSingleAltCaseExpr binds var b a
+
flattenExpr _ _ = do
projects / matthijs / master-project / cλash.git / blobdiff