X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=da665cf3fdb1f768235d394efd285f1302bb1f8a;hb=9b7d00ad53acfc821840051ef693d87470b4462b;hp=115460c19e975da9311f600dad3d0283fa2a57a8;hpb=e2a1b9504807512be2e613c9e8822658be6fa626;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index 115460c..da665cf 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -7,7 +7,10 @@ import qualified Name 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 @@ -28,7 +31,7 @@ dataConAppArgs dc args = genSignals :: Type.Type - -> FlattenState (SignalMap UnnamedSignal) + -> FlattenState SignalMap genSignals ty = -- First generate a map with the right structure containing the types, and @@ -37,13 +40,13 @@ genSignals ty = -- | Marks a signal as the given SigUse, if its id is in the list of id's -- given. -markSignals :: SigUse -> [UnnamedSignal] -> (UnnamedSignal, SignalInfo) -> (UnnamedSignal, SignalInfo) +markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) markSignals use ids (id, info) = (id, info') where info' = if id `elem` ids then info { sigUse = use} else info -markSignal :: SigUse -> UnnamedSignal -> (UnnamedSignal, SignalInfo) -> (UnnamedSignal, SignalInfo) +markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) markSignal use id = markSignals use [id] -- | Flatten a haskell function @@ -54,27 +57,81 @@ flattenFunction :: flattenFunction _ (Rec _) = error "Recursive binders not supported" flattenFunction hsfunc bind@(NonRec var expr) = - FlatFunction args res apps conds sigs'''' + FlatFunction args res defs sigs where - init_state = ([], [], [], 0) - (fres, end_state) = State.runState (flattenExpr [] expr) init_state - (apps, conds, sigs, _) = end_state + init_state = ([], [], 0) + (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 - -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal)) + -> FlattenState ([SignalMap], SignalMap) flattenExpr binds lam@(Lam b expr) = do -- Find the type of the binder @@ -85,14 +142,25 @@ flattenExpr binds lam@(Lam b expr) = do (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? @@ -106,8 +174,38 @@ flattenExpr binds app@(App _ _) = do 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) @@ -132,7 +230,7 @@ flattenExpr binds app@(App _ _) = do appArgs = arg_ress, appRes = res } - addApp app + 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 @@ -154,43 +252,137 @@ flattenExpr binds l@(Let (NonRec b bexpr) expr) = do 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) + -- TODO include b in the binds list + [alt] -> flattenSingleAltCaseExpr binds res b alt + -- Reverse the alternatives, so the __DEFAULT alternative ends up last + otherwise -> flattenMultipleAltCaseExpr binds res b (reverse 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 UnnamedSignal], SignalMap UnnamedSignal) - -- 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) - -- TODO include b in the binds list + Tuple tuple_sigs = scrut -- 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 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 + -> 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 + 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 + 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 - -flattenExpr _ _ = do - return ([], Tuple []) + 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 scrut b (a:alts) = + flattenSingleAltCaseExpr binds scrut b a + +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 + +-- | 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'"; "DontCare" -> "'-'" + 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 @@ -208,9 +400,9 @@ appToHsFunction ty f args = -- | Filters non-state signals and returns the state number and signal id for -- state values. filterState :: - UnnamedSignal -- | The signal id to look at + SignalId -- | The signal id to look at -> HsValueUse -- | How is this signal used? - -> Maybe (Int, UnnamedSignal ) -- | The state num and signal id, if this + -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this -- signal was used as state filterState id (State num) = @@ -221,8 +413,8 @@ filterState _ _ = Nothing -- signals in the given maps. stateList :: HsUseMap - -> (SignalMap UnnamedSignal) - -> [(Int, UnnamedSignal)] + -> (SignalMap) + -> [(StateId, SignalId)] stateList uses signals = Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses @@ -231,7 +423,7 @@ stateList uses signals = getOwnStates :: HsFunction -- | The function to look at -> FlatFunction -- | The function to look at - -> [(Int, SignalInfo, SignalInfo)] + -> [(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.