module Flatten where
import CoreSyn
-import Control.Monad
+import qualified Control.Monad as Monad
import qualified Var
import qualified Type
import qualified Name
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.Traversable as Traversable
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
import FlattenTypes
+import CoreTools
-- Extract the arguments from a data constructor application (that is, the
-- normal args, leaving out the type args).
-- | Flatten a haskell function
flattenFunction ::
HsFunction -- ^ The function to flatten
- -> CoreBind -- ^ The function value
+ -> (CoreBndr, CoreExpr) -- ^ The function value
-> FlatFunction -- ^ The resulting flat function
-flattenFunction _ (Rec _) = error "Recursive binders not supported"
-flattenFunction hsfunc bind@(NonRec var expr) =
+flattenFunction hsfunc (var, expr) =
FlatFunction args res defs sigs
where
init_state = ([], [], 0)
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)
-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
+ 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 Nothing) 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)
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
+ 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)
+ ([], a) <- flattenExpr binds (last $ init args)
+ ([], b) <- flattenExpr binds (last args)
+ res <- mkEqComparisons a b
+ return ([], res)
+ else if fname == "fromInteger" then do
+ let [to_ty, to_dict, val] = args
+ -- We assume this is an application of the GHC.Integer.smallInteger
+ -- function to a literal
+ let App smallint (Lit lit) = val
+ let (Literal.MachInt int) = lit
+ let ty = CoreUtils.exprType app
+ sig_id <- genSignalId SigInternal ty
+ -- TODO: fromInteger is defined for more types than just SizedWord
+ let len = sized_word_len ty
+ -- Use a to_unsigned to translate the number (a natural) to an unsiged
+ -- (array of bits)
+ let lit_str = "to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ ")"
+ -- Set the signal to our literal unconditionally, but add the type so
+ -- the literal will be typecast to the proper type.
+ addDef $ UncondDef (Right $ Literal lit_str (Just ty)) sig_id
+ return ([], Single sig_id)
+ 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
+ -- 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
+
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
- -- 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)
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)
-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
+ -- Put the scrutinee in the BindMap
+ let binds' = (b, Left res) : binds
case alts of
- [alt] -> flattenSingleAltCaseExpr binds var b alt
- otherwise -> flattenMultipleAltCaseExpr binds var b alts
+ [alt] -> flattenSingleAltCaseExpr binds' res b alt
+ -- Reverse the alternatives, so the __DEFAULT alternative ends up last
+ otherwise -> flattenMultipleAltCaseExpr binds' res b (reverse 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
- -> BindValue -- The scrutinee
+ -> SignalMap -- The scrutinee
-> CoreBndr -- The binder to bind the scrutinee to
-> CoreAlt -- The single alternative
-> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
- flattenSingleAltCaseExpr binds var b alt@(DataAlt datacon, bind_vars, expr) =
+ 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.
- 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
+ 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 ::
BindMap
-- A list of bindings in effect
- -> BindValue -- The scrutinee
+ -> SignalMap -- 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)
+ 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
- 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."
+ 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
addDef (CondDef boolsigid true false res)
return res
- flattenMultipleAltCaseExpr binds var b (a:alts) =
- flattenSingleAltCaseExpr binds var b a
-
-
-
-flattenExpr _ _ = do
- return ([], Tuple [])
+ flattenMultipleAltCaseExpr binds scrut b (a:alts) =
+ flattenSingleAltCaseExpr binds scrut b a
+
+flattenExpr _ expr = do
+ error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
+
+-- | 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.
+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
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:
projects / matthijs / master-project / cλash.git / blobdiff