import qualified Control.Arrow as Arrow
import qualified DataCon
import qualified TyCon
+import qualified Literal
import qualified CoreUtils
import qualified TysWiredIn
import qualified IdInfo
import qualified Data.Foldable as Foldable
import Control.Applicative
import Outputable ( showSDoc, ppr )
-import qualified Control.Monad.State as State
+import qualified Control.Monad.Trans.State as State
import HsValueMap
import TranslatorTypes
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
- 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)
+ 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)
+ IdInfo.VanillaGlobal ->
+ -- Treat references to globals as an application with zero elements
+ flattenApplicationExpr binds (CoreUtils.exprType var) id []
otherwise ->
error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
flattenBuildTupleExpr binds args = do
-- Flatten each of our args
- flat_args <- (State.mapM (flattenExpr binds) args)
+ flat_args <- (mapM (flattenExpr binds) args)
-- Check and split each of the arguments
let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
let res = Tuple arg_ress
return ([], res)
- -- | Flatten a normal application expression
- flattenApplicationExpr binds ty f args = do
- -- Find the function to call
- let func = appToHsFunction ty f args
- -- Flatten each of our args
- flat_args <- (State.mapM (flattenExpr binds) args)
- -- Check and split each of the arguments
- 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,
- appArgs = arg_ress,
- appRes = res
- }
- addDef app
- return ([], res)
- -- | Check a flattened expression to see if it is valid to use as a
- -- function argument. The first argument is the original expression for
- -- use in the error message.
- checkArg arg flat =
- let (args, res) = flat in
- if not (null args)
- then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
- else flat
-
flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
(b_args, b_res) <- flattenExpr binds bexpr
if not (null b_args)
(args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts)
case a of
(DataAlt datacon, bind_vars, expr) -> do
- 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)
+ 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
+-- | Flatten a normal application expression
+flattenApplicationExpr binds ty f args = do
+ -- Find the function to call
+ let func = appToHsFunction ty f args
+ -- Flatten each of our args
+ flat_args <- (mapM (flattenExpr binds) args)
+ -- Check and split each of the arguments
+ 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,
+ appArgs = arg_ress,
+ appRes = res
+ }
+ addDef app
+ return ([], res)
+-- | Check a flattened expression to see if it is valid to use as a
+-- function argument. The first argument is the original expression for
+-- use in the error message.
+checkArg arg flat =
+ let (args, res) = flat in
+ if not (null args)
+ then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
+ else flat
-- | Translates a dataconstructor without arguments to the corresponding
-- literal.
-- 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'"; "DontCare" -> "'-'"
+ let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
return lit
"Bool" -> do
let dcname = DataCon.dataConName datacon
stateList uses signals =
Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
--- | Returns pairs of signals that should be mapped to state in this function.
-getOwnStates ::
- HsFunction -- | The function to look at
- -> FlatFunction -- | The function to look at
- -> [(StateId, SignalInfo, SignalInfo)]
- -- | The state signals. The first is the state number, the second the
- -- signal to assign the current state to, the last is the signal
- -- that holds the new state.
-
-getOwnStates hsfunc flatfunc =
- [(old_num, old_info, new_info)
- | (old_num, old_info) <- args_states
- , (new_num, new_info) <- res_states
- , old_num == new_num]
- where
- sigs = flat_sigs flatfunc
- -- Translate args and res to lists of (statenum, sigid)
- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
- -- Replace the second tuple element with the corresponding SignalInfo
- args_states = map (Arrow.second $ signalInfo sigs) args
- res_states = map (Arrow.second $ signalInfo sigs) res
-
-
-- vim: set ts=8 sw=2 sts=2 expandtab: