Flatten.hs

   1 module Flatten where
   2 import CoreSyn
   3 import Control.Monad
   4 import qualified Var
   5 import qualified Type
   6 import qualified Name
   7 import qualified Maybe
   8 import qualified Control.Arrow as Arrow
   9 import qualified DataCon
  10 import qualified TyCon
  11 import qualified CoreUtils
  12 import qualified TysWiredIn
  13 import qualified Data.Traversable as Traversable
  14 import qualified Data.Foldable as Foldable
  15 import Control.Applicative
  16 import Outputable ( showSDoc, ppr )
  17 import qualified Control.Monad.State as State
  18
  19 import HsValueMap
  20 import TranslatorTypes
  21 import FlattenTypes
  22
  23 -- Extract the arguments from a data constructor application (that is, the
  24 -- normal args, leaving out the type args).
  25 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
  26 dataConAppArgs dc args =
  27     drop tycount args
  28   where
  29     tycount = length $ DataCon.dataConAllTyVars dc
  30
  31 genSignals ::
  32   Type.Type
  33   -> FlattenState SignalMap
  34
  35 genSignals ty =
  36   -- First generate a map with the right structure containing the types, and
  37   -- generate signals for each of them.
  38   Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty)
  39
  40 -- | Marks a signal as the given SigUse, if its id is in the list of id's
  41 --   given.
  42 markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
  43 markSignals use ids (id, info) =
  44   (id, info')
  45   where
  46     info' = if id `elem` ids then info { sigUse = use} else info
  47
  48 markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
  49 markSignal use id = markSignals use [id]
  50
  51 -- | Flatten a haskell function
  52 flattenFunction ::
  53   HsFunction                      -- ^ The function to flatten
  54   -> CoreBind                     -- ^ The function value
  55   -> FlatFunction                 -- ^ The resulting flat function
  56
  57 flattenFunction _ (Rec _) = error "Recursive binders not supported"
  58 flattenFunction hsfunc bind@(NonRec var expr) =
  59   FlatFunction args res defs sigs
  60   where
  61     init_state        = ([], [], 0)
  62     (fres, end_state) = State.runState (flattenTopExpr hsfunc expr) init_state
  63     (defs, sigs, _)   = end_state
  64     (args, res)       = fres
  65
  66 flattenTopExpr ::
  67   HsFunction
  68   -> CoreExpr
  69   -> FlattenState ([SignalMap], SignalMap)
  70
  71 flattenTopExpr hsfunc expr = do
  72   -- Flatten the expression
  73   (args, res) <- flattenExpr [] expr
  74
  75   -- Join the signal ids and uses together
  76   let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
  77   let zipped_res = zipValueMaps res (hsFuncRes hsfunc)
  78   -- Set the signal uses for each argument / result, possibly updating
  79   -- argument or result signals.
  80   args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args
  81   res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res
  82   return (args', res')
  83   where
  84     args_use Port = SigPortIn
  85     args_use (State n) = SigStateOld n
  86     res_use Port = SigPortOut
  87     res_use (State n) = SigStateNew n
  88
  89
  90 hsUseToSigUse ::
  91   (HsValueUse -> SigUse)      -- ^ A function to actually map the use value
  92   -> (SignalId, HsValueUse)   -- ^ The signal to look at and its use
  93   -> FlattenState SignalId    -- ^ The resulting signal. This is probably the
  94                               --   same as the input, but it could be different.
  95 hsUseToSigUse f (id, use) = do
  96   info <- getSignalInfo id
  97   id' <- case sigUse info of
  98     -- Internal signals can be marked as different uses freely.
  99     SigInternal -> do
 100       return id
 101     -- Signals that already have another use, must be duplicated before
 102     -- marking. This prevents signals mapping to the same input or output
 103     -- port or state variables and ports overlapping, etc.
 104     otherwise -> do
 105       duplicateSignal id
 106   setSignalInfo id' (info { sigUse = f use})
 107   return id'
 108
 109 -- | Creates a new internal signal with the same type as the given signal
 110 copySignal :: SignalId -> FlattenState SignalId
 111 copySignal id = do
 112   -- Find the type of the original signal
 113   info <- getSignalInfo id
 114   let ty = sigTy info
 115   -- Generate a new signal (which is SigInternal for now, that will be
 116   -- sorted out later on).
 117   genSignalId SigInternal ty
 118
 119 -- | Duplicate the given signal, assigning its value to the new signal.
 120 --   Returns the new signal id.
 121 duplicateSignal :: SignalId -> FlattenState SignalId
 122 duplicateSignal id = do
 123   -- Create a new signal
 124   id' <- copySignal id
 125   -- Assign the old signal to the new signal
 126   addDef $ UncondDef (Left id) id'
 127   -- Replace the signal with the new signal
 128   return id'
 129
 130 flattenExpr ::
 131   BindMap
 132   -> CoreExpr
 133   -> FlattenState ([SignalMap], SignalMap)
 134
 135 flattenExpr binds lam@(Lam b expr) = do
 136   -- Find the type of the binder
 137   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
 138   -- Create signal names for the binder
 139   defs <- genSignals arg_ty
 140   let binds' = (b, Left defs):binds
 141   (args, res) <- flattenExpr binds' expr
 142   return (defs : args, res)
 143
 144 flattenExpr binds (Var id) =
 145   case bind of
 146     Left sig_use -> return ([], sig_use)
 147     Right _ -> error "Higher order functions not supported."
 148   where
 149     bind = Maybe.fromMaybe
 150       (error $ "Argument " ++ Name.getOccString id ++ " is unknown")
 151       (lookup id binds)
 152
 153 flattenExpr binds app@(App _ _) = do
 154   -- Is this a data constructor application?
 155   case CoreUtils.exprIsConApp_maybe app of
 156     -- Is this a tuple construction?
 157     Just (dc, args) -> if DataCon.isTupleCon dc
 158       then
 159         flattenBuildTupleExpr binds (dataConAppArgs dc args)
 160       else
 161         error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
 162     otherwise ->
 163       -- Normal function application
 164       let ((Var f), args) = collectArgs app in
 165       flattenApplicationExpr binds (CoreUtils.exprType app) f args
 166   where
 167     flattenBuildTupleExpr binds args = do
 168       -- Flatten each of our args
 169       flat_args <- (State.mapM (flattenExpr binds) args)
 170       -- Check and split each of the arguments
 171       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 172       let res = Tuple arg_ress
 173       return ([], res)
 174
 175     -- | Flatten a normal application expression
 176     flattenApplicationExpr binds ty f args = do
 177       -- Find the function to call
 178       let func = appToHsFunction ty f args
 179       -- Flatten each of our args
 180       flat_args <- (State.mapM (flattenExpr binds) args)
 181       -- Check and split each of the arguments
 182       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 183       -- Generate signals for our result
 184       res <- genSignals ty
 185       -- Create the function application
 186       let app = FApp {
 187         appFunc = func,
 188         appArgs = arg_ress,
 189         appRes  = res
 190       }
 191       addDef app
 192       return ([], res)
 193     -- | Check a flattened expression to see if it is valid to use as a
 194     --   function argument. The first argument is the original expression for
 195     --   use in the error message.
 196     checkArg arg flat =
 197       let (args, res) = flat in
 198       if not (null args)
 199         then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
 200         else flat
 201
 202 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
 203   (b_args, b_res) <- flattenExpr binds bexpr
 204   if not (null b_args)
 205     then
 206       error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
 207     else
 208       let binds' = (b, Left b_res) : binds in
 209       flattenExpr binds' expr
 210
 211 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
 212
 213 flattenExpr binds expr@(Case (Var v) b _ alts) =
 214   case alts of
 215     [alt] -> flattenSingleAltCaseExpr binds var b alt
 216     otherwise -> flattenMultipleAltCaseExpr binds var b alts
 217   where
 218     var = Maybe.fromMaybe
 219       (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
 220       (lookup v binds)
 221
 222     flattenSingleAltCaseExpr ::
 223       BindMap
 224                                 -- A list of bindings in effect
 225       -> BindValue              -- The scrutinee
 226       -> CoreBndr               -- The binder to bind the scrutinee to
 227       -> CoreAlt                -- The single alternative
 228       -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
 229
 230     flattenSingleAltCaseExpr binds var b alt@(DataAlt datacon, bind_vars, expr) =
 231       if DataCon.isTupleCon datacon
 232         then
 233           let
 234             -- Unpack the scrutinee (which must be a variable bound to a tuple) in
 235             -- the existing bindings list and get the portname map for each of
 236             -- it's elements.
 237             Left (Tuple tuple_sigs) = var
 238             -- TODO include b in the binds list
 239             -- Merge our existing binds with the new binds.
 240             binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
 241           in
 242             -- Expand the expression with the new binds list
 243             flattenExpr binds' expr
 244         else
 245           if null bind_vars
 246             then
 247               -- DataAlts without arguments don't need processing
 248               -- (flattenMultipleAltCaseExpr will have done this already).
 249               flattenExpr binds expr
 250             else
 251               error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 252     flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 253
 254     flattenMultipleAltCaseExpr ::
 255       BindMap
 256                                 -- A list of bindings in effect
 257       -> BindValue              -- The scrutinee
 258       -> CoreBndr               -- The binder to bind the scrutinee to
 259       -> [CoreAlt]              -- The alternatives
 260       -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
 261
 262     flattenMultipleAltCaseExpr binds var b (a:a':alts) = do
 263       (args, res) <- flattenSingleAltCaseExpr binds var b a
 264       (args', res') <- flattenMultipleAltCaseExpr binds var b (a':alts)
 265       case a of
 266         (DataAlt datacon, bind_vars, expr) -> do
 267           let tycon = DataCon.dataConTyCon datacon
 268           let tyname = TyCon.tyConName tycon
 269           case Name.getOccString tyname of
 270             -- TODO: Do something more robust than string matching
 271             "Bit"      -> do
 272               -- The scrutinee must be a single signal
 273               let Left (Single sig) = var
 274               let dcname = DataCon.dataConName datacon
 275               let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 276               -- Create a signal that contains a boolean
 277               boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
 278               let expr = EqLit sig lit
 279               addDef (UncondDef (Right expr) boolsigid)
 280               -- Create conditional assignments of either args/res or
 281               -- args'/res based on boolsigid, and return the result.
 282               our_args <- zipWithM (mkConditionals boolsigid) args args'
 283               our_res  <- mkConditionals boolsigid res res'
 284               return (our_args, our_res)
 285             otherwise ->
 286               error $ "Type " ++ (Name.getOccString tyname) ++ " not supported in multiple alternative case expressions."
 287         otherwise ->
 288           error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
 289       where
 290         -- Select either the first or second signal map depending on the value
 291         -- of the first argument (True == first map, False == second map)
 292         mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap
 293         mkConditionals boolsigid true false = do
 294           let zipped = zipValueMaps true false
 295           Traversable.mapM (mkConditional boolsigid) zipped
 296
 297         mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId
 298         mkConditional boolsigid (true, false) = do
 299           -- Create a new signal (true and false should be identically typed,
 300           -- so it doesn't matter which one we copy).
 301           res <- copySignal true
 302           addDef (CondDef boolsigid true false res)
 303           return res
 304
 305     flattenMultipleAltCaseExpr binds var b (a:alts) =
 306       flattenSingleAltCaseExpr binds var b a
 307
 308
 309
 310 flattenExpr _ _ = do
 311   return ([], Tuple [])
 312
 313 appToHsFunction ::
 314   Type.Type       -- ^ The return type
 315   -> Var.Var      -- ^ The function to call
 316   -> [CoreExpr]   -- ^ The function arguments
 317   -> HsFunction   -- ^ The needed HsFunction
 318
 319 appToHsFunction ty f args =
 320   HsFunction hsname hsargs hsres
 321   where
 322     hsname = Name.getOccString f
 323     hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
 324     hsres  = useAsPort (mkHsValueMap ty)
 325
 326 -- | Filters non-state signals and returns the state number and signal id for
 327 --   state values.
 328 filterState ::
 329   SignalId                       -- | The signal id to look at
 330   -> HsValueUse                  -- | How is this signal used?
 331   -> Maybe (StateId, SignalId )  -- | The state num and signal id, if this
 332                                  --   signal was used as state
 333
 334 filterState id (State num) =
 335   Just (num, id)
 336 filterState _ _ = Nothing
 337
 338 -- | Returns a list of the state number and signal id of all used-as-state
 339 --   signals in the given maps.
 340 stateList ::
 341   HsUseMap
 342   -> (SignalMap)
 343   -> [(StateId, SignalId)]
 344
 345 stateList uses signals =
 346     Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
 347
 348 -- | Returns pairs of signals that should be mapped to state in this function.
 349 getOwnStates ::
 350   HsFunction                      -- | The function to look at
 351   -> FlatFunction                 -- | The function to look at
 352   -> [(StateId, SignalInfo, SignalInfo)]
 353         -- | The state signals. The first is the state number, the second the
 354         --   signal to assign the current state to, the last is the signal
 355         --   that holds the new state.
 356
 357 getOwnStates hsfunc flatfunc =
 358   [(old_num, old_info, new_info)
 359     | (old_num, old_info) <- args_states
 360     , (new_num, new_info) <- res_states
 361     , old_num == new_num]
 362   where
 363     sigs = flat_sigs flatfunc
 364     -- Translate args and res to lists of (statenum, sigid)
 365     args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
 366     res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
 367     -- Replace the second tuple element with the corresponding SignalInfo
 368     args_states = map (Arrow.second $ signalInfo sigs) args
 369     res_states = map (Arrow.second $ signalInfo sigs) res
 370
 371
 372 -- vim: set ts=8 sw=2 sts=2 expandtab: