diff --git a/Curry/Base/MessageMonad.hs b/Curry/Base/MessageMonad.hs --- a/Curry/Base/MessageMonad.hs +++ b/Curry/Base/MessageMonad.hs @@ -1,9 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {- - The \texttt{MsgMonad} type is used for describing the result of a - computation that can fail. In contrast to the standard \texttt{Maybe} - type, its \texttt{Error} case provides for an error message that - describes the failure. + The monads MsgMonad and MsgMonadIO provide a common way + to log warning messages and to stop execution when an + error occurs. They may be used to integrate different + compiler passes smoothly. + + (c) 2009, Holger Siegel. + -} module Curry.Base.MessageMonad where diff --git a/Curry/ExtendedFlat/LiftLetrec.hs b/Curry/ExtendedFlat/LiftLetrec.hs new file mode 100644 --- /dev/null +++ b/Curry/ExtendedFlat/LiftLetrec.hs @@ -0,0 +1,98 @@ +{- + Turn recursive data declarations into recursive + function calls. + + Only single recursive declarations are transformed. + Mutually recursive declarations are left unchanged. + You should use transformation UnMutual first. + + (c) 2009, Holger Siegel. +-} + +module Curry.ExtendedFlat.LiftLetrec(liftLetrecProg) where + +import Data.List +import Control.Monad.State +import Data.Maybe +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Curry.ExtendedFlat.Type +import Curry.ExtendedFlat.Goodies +import Curry.ExtendedFlat.MonadicGoodies + + + +data LifterState = LifterState { modname :: String, + currentFunc :: String, + globals :: Set.Set QName, + globalCounter :: Map.Map QName Int, + localCounter :: Int, + lifted :: Map.Map QName FuncDecl } + + +type Bind = (VarIndex, Expr) -- (name, value) +type LiftMonad = State LifterState + + +liftLetrecProg :: Prog -> Prog +liftLetrecProg prog = updProg id id id (++ fdecls) id prog' + where state = LifterState { + modname = progName prog, + currentFunc = "anonymous", + globals = Set.fromList g, + globalCounter = Map.fromList $ zip g (repeat 1), + localCounter = 0, + lifted = Map.empty + } + g = allGlobals prog + (prog', state') = runState (updProgFuncsM run prog) state + fdecls = Map.elems (lifted state') + run fdecl = do + let fname = localName (funcName fdecl) + modify (\st -> st { currentFunc = fname, + localCounter = (maximum . map idxOf . allVarsInFunc) fdecl + }) + fdecl' <- updFuncLetsM liftRecursion fdecl + modify (\st -> st {currentFunc = "anonymous"}) + return fdecl' + + + +liftRecursion :: [Bind] -> Expr -> LiftMonad Expr +liftRecursion [(b, rhs)] body + | b `elem` fv = do globalcall <- mkLiftedFunction (typeofVar b) b rhs (fv \\ [b]) + return (Let [(b, globalcall)] body) + | otherwise = return (Let [(b, rhs)] body) + where fv = fvs rhs +liftRecursion bs body = return (Let bs body) + + +mkLiftedFunction :: Maybe TypeExpr -> VarIndex -> Expr -> [VarIndex] -> LiftMonad Expr +mkLiftedFunction t v rhs fv + = do name <- newGlobalName t + st <- get + let fcall = (Comb FuncCall name (map Var fv)) + -- FIXME Typ der Funktion muss irgendwie ermittelt werden :( + let fdecl = Func name (length fv) Private (fromMaybe (TVar 0) t) (Rule fv (Let [(v,fcall)] rhs)) + put st { lifted = Map.insert name fdecl (lifted st), + globals = Set.insert name (globals st) + } + return fcall + + +newGlobalName :: Maybe TypeExpr -> LiftMonad QName +newGlobalName t + = do st <- get + let qn = QName Nothing t (modname st) (currentFunc st) + let counter = Map.findWithDefault 1 qn (globalCounter st) + put st { globalCounter = Map.insert qn (counter + 1) (globalCounter st) } + let qn' = QName Nothing t (modname st) (localName qn ++ "_" ++ show counter) + if qn' `Set.member` globals st + then newGlobalName t + else return qn' + + +allGlobals :: Prog -> [QName] +allGlobals prog = [n | Func n _ _ _ _ <- fs] + where fs = progFuncs prog diff --git a/Curry/ExtendedFlat/MonadicGoodies.hs b/Curry/ExtendedFlat/MonadicGoodies.hs --- a/Curry/ExtendedFlat/MonadicGoodies.hs +++ b/Curry/ExtendedFlat/MonadicGoodies.hs @@ -1,3 +1,9 @@ +{- + Monadic transformations of ExtendedFlat programs. + + (c) 2009, Holger Siegel. +-} + module Curry.ExtendedFlat.MonadicGoodies (UpdateM, postOrderM, updFuncExpsM, updProgFuncsM, updFuncLetsM) where diff --git a/Curry/ExtendedFlat/TypeInference.hs b/Curry/ExtendedFlat/TypeInference.hs --- a/Curry/ExtendedFlat/TypeInference.hs +++ b/Curry/ExtendedFlat/TypeInference.hs @@ -1,5 +1,16 @@ {-# LANGUAGE FlexibleContexts, PatternGuards #-} +{- + Function adjustTypeInfos annotates every declaration, + identifier, and application with exact type information. + + This information is derived from the more general information + found in the AST. + + (c) 2009, Holger Siegel. + +-} + module Curry.ExtendedFlat.TypeInference ( dispType, adjustTypeInfo, diff --git a/Curry/ExtendedFlat/UnMutual.hs b/Curry/ExtendedFlat/UnMutual.hs new file mode 100644 --- /dev/null +++ b/Curry/ExtendedFlat/UnMutual.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE RecursiveDo #-} + +{- + Turns mutually recursive declarations into a single recursive + declaration, of a tuple value, trying to minimize the number + of the tuple. This is an implementation of the algorithm described in + http://www.informatik.uni-kiel.de/~mh/lehre/diplomarbeiten/siegel.pdf + + (c) 2009, Holger Siegel. +-} +module Curry.ExtendedFlat.UnMutual(unMutualProg) where + +import Data.Graph +-- import Data.Function(on) +import Data.Maybe +import Data.List +import Control.Monad.State + +import Curry.Base.Position(noRef) +import Curry.ExtendedFlat.Type +import Curry.ExtendedFlat.Goodies +import Curry.ExtendedFlat.MonadicGoodies + + +type Bind = (VarIndex, Expr) -- (name, value) + +newtype UnMutualState = UnMutualState { localCounter :: Int } + + +type UnMutualMonad = State UnMutualState + + +unMutualProg :: Prog -> Prog +unMutualProg p = evalState (updProgFuncsM + (\fdecl -> do + modify (\st -> st { localCounter = (maximum . map idxOf . allVarsInFunc) fdecl}) + updFuncLetsM rmMutualRecursion fdecl) + p) (UnMutualState 1000) + +rmMutualRecursion :: [Bind] -> Expr -> UnMutualMonad Expr +rmMutualRecursion bs body + | allWhnf bs || length bs <= 1 + = return (Let bs body) + | otherwise + = mdo (body', bound, fbs) <- partitionBinds (fvs body) sccs (body, mkTuple fbs, []) + mkSingleLet body' bound fbs + where fvsGraph = depGraph bs + sccs = sortSccs fvsGraph + + +mkSingleLet :: Expr -> Expr -> [VarIndex] -> UnMutualMonad Expr +mkSingleLet e2 e1 [v] + = return (Let [(v, e1)] e2) +mkSingleLet body bound fbs + = do recname <- newLocalName (Just fbsType) + bound' <- mkFbSelectors recname bound + body' <- mkFbSelectors recname body + + return (Let [(recname, bound')] body') + where + fbsType = TCons (mkQName tuplecon) (map (fromJust . typeofVar) fbs) + tuplecon = ("Prelude", "(" ++ replicate (length fbs -1 ) ',' ++ ")") + mkFbSelectors recname b = foldM (mkSelector recname)b fbs + mkSelector recname b v = nonrecLet v (mkSel (Var recname) v fbs) b + + +-- Some self-explaining helper functions: + + +-- FIXME rename, wenn x in (fvs e1) ! +-- immer rename wg. Shadowing +-- (siehe Test.curry) +nonrecLet :: VarIndex -> Expr -> Expr -> UnMutualMonad Expr +nonrecLet x e1 e2 + | x `elem` allVars e1 + = do vi <- newLocalName (typeofVar x) + let e2' = subst x (Var vi) e2 + return (Let [(vi,e1)] e2') + | otherwise = return (Let [(x,e1)] e2) + + +mkTuple :: [VarIndex] -> Expr +mkTuple [e] = Var e +mkTuple es = Comb ConsCall (mkTupleConstr es) $ map Var es + + +mkTupleConstr :: [a] -> QName +mkTupleConstr arity = curry mkQName "Prelude" ("(" ++ replicate (length arity-1) ',' ++ ")") + +mkSel :: Expr -> VarIndex -> [VarIndex] -> Expr +mkSel e v vs = Case noRef Rigid e [Branch pat (Var v)] + where pat = Pattern tcon vs + tcon = mkTupleConstr vs + + +allWhnf :: [Bind] -> Bool +allWhnf = all (whnf . snd) + +{- +The type |FvsNode| stands for a single node in a dependency graph. +It contains the binding, i.e. the identifier and the right hand side, as well +as a list of the identifiers the right hand side refers to. + +Function |depGraph| turns a list of bindings into a dependency graph. + +Function |sortSccs| calculates a list of strongly connected components +with the help of the library function |stronglyConnCompR|. +In contrast to the list of SCCs returned from this function, +the list of SCCs returned by |sortSccs| is in reversed order. +This is required, beacuase we start to process nested +declarations at the innermost binding. +-} + +type FvsNode = (Bind, VarIndex, [VarIndex]) + +depGraph :: [Bind] -> [FvsNode] +depGraph = map (\(x, e) -> ((x, e), x, fvs e)) + + +sortSccs :: [FvsNode] -> [SCC FvsNode] +sortSccs = reverse . stronglyConnCompR + + +{- +Function |partitionBinds| takes the following arguments: A list of identifier that occur +in the body of the declaration, a sorted list of strongy connected components, +a 3-tuple consising of the body of the declaration, a tuple expression that contains the +feedback variables, and the list of identifiers that are already added to the feedback set. +It returns an updated version of that 3-tuple, in which the body expression is 'surrounded' +by declarations of identifiers that the body refers to, the tuple expression is 'surrounded' +by declarations that are needed to define the feedback vriables, and the set of feedback +identifiers is the complete feedback set: +-} +partitionBinds :: [VarIndex] -> [SCC FvsNode] + -> (Expr, Expr, [VarIndex]) + -> UnMutualMonad (Expr, Expr, [VarIndex]) + +-- When there is no binding left in a strongly connected component, +-- then move to the next SCC: +partitionBinds pull (CyclicSCC []:ds) part + = partitionBinds pull ds part + +{- If the next SCC is cyclic, then pick the best candidate for the feedback set +and remove it from the SCC. The rest of the SCC breaks into smaller SCCs that are sorted +and added to the remaining list of SCCs. The selected candidate is added to the feedback set, +and its declaration is added to the tuple expression: -} +partitionBinds pull (CyclicSCC d:ds) (body, bound, fbs) + = let (b@(v,e), d') = pickFbNode pull d + sccs = sortSccs d' ++ ds + in do l <- nonrecLet v e bound + partitionBinds pull sccs (body, l, fst b:fbs) + +-- If the next SCC is acyclic, then it is not added to the feedback set. Instead, +-- its declaration is added to the tuple expression. Depending on whether it +-- is needed in the body expression, its declaration is also added to the body expression: +partitionBinds pull (AcyclicSCC ((x,e),_,r):ds) (body, bound, fbs) + = do l <- nonrecLet x e bound + (body', pull') <- if x `elem` pull + then do l' <- nonrecLet x e body + return (l', r `union` pull) + else return (body, pull) + partitionBinds pull' ds (body', l, fbs) + +-- When there are no more declarations to be processed, the 3-tuple is returned as +-- result: +partitionBinds _pull [] part + = return part + + + +-- Function |pickFbNode| picks the best candidate from a SCC. Irs choice depends +-- not only on the SCC, but also on whether the candidate is referred to by the body expression: + +pickFbNode :: [VarIndex] -> [FvsNode] -> (Bind, [FvsNode]) +pickFbNode pull defs = (b, d) + where + ds = [x | (_, x, _) <- defs] + (b, y, _) = maximumBy (compare `on` weight pull ds) defs + d = [ n | n@(_, x, _) <- defs, x /= y] + +-- not in ghc 6.8.2: +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +on (.*.) f x y = f x .*. f y + +{- +Function |weight| estimates the usefulness of adding an identifier to the feedback set. +It uses the fact, that tuples are sorted in exicographic order by default. An identifier is +rated on whether it +\begin{enumerate} + \item has a recursive reference to itself, + \item has a high number of references to other identifiers in the same SCC, or + \item is referred to by the body expression. +\end{enumerate} +-} + +weight :: [VarIndex] -> [VarIndex] -> FvsNode -> (Bool, Int, Bool) +weight pull defs (_,x,fv) = (recursive, length incoming, pulled) + where recursive = x `elem` fv + incoming = fv `intersect` defs + pulled = x `elem` pull + + + +newLocalName :: Maybe TypeExpr -> UnMutualMonad VarIndex +newLocalName t + = do st <- get + let counter = 1 + localCounter st + put st { localCounter = counter } + return (VarIndex t counter) + + +subst :: VarIndex -> Expr -> Expr -> Expr +subst v x = po + where po e@(Var v') + | v==v' = x + | otherwise = e + po e@(Lit _) + = e + po (Comb t n es) + = Comb t n (map po es) + po e@(Free vs e') + | v `elem` vs = e + | otherwise = Free vs (po e') + po e@(Let bs e') + | lookup v bs == Nothing + = Let (map poBind bs) (po e') + | otherwise = e + po (Or l r) = Or (po l) (po r) + po (Case p t e bs) = Case p t (po e) (map poBranch bs) + poBind (w, rhs) = (w, po rhs) + poBranch e@(Branch p rhs) + | v `elem` trPattern (\_ args -> args) (const []) p + = e + | otherwise + = Branch p (po rhs) + + + diff --git a/Curry/Files/Filenames.hs b/Curry/Files/Filenames.hs --- a/Curry/Files/Filenames.hs +++ b/Curry/Files/Filenames.hs @@ -1,3 +1,13 @@ +{- + Filename mangling for several intermediate file formats. + + The functions in this module were collected from several + compiler modules in order to provide a unique accessing + point for this functionality. + + (c) 2009, Holger Siegel. +-} + module Curry.Files.Filenames where import System.FilePath diff --git a/curry-base.cabal b/curry-base.cabal --- a/curry-base.cabal +++ b/curry-base.cabal @@ -1,5 +1,5 @@ Name: curry-base -Version: 0.2.3 +Version: 0.2.4 Cabal-Version: >= 1.6 Synopsis: Functions for manipulating Curry programs Description: This package serves as a foundation for Curry compilers. it defines the intermediate @@ -17,8 +17,9 @@ Library Build-Depends: base >= 3 && < 4, mtl, old-time, directory, filepath, containers, pretty - ghc-options: -Wall -fwarn-unused-binds -fwarn-unused-imports -auto-all + ghc-options: Exposed-Modules: Curry.Base.Position, Curry.Base.Ident, Curry.Base.MessageMonad - Curry.ExtendedFlat.Type, Curry.ExtendedFlat.Goodies, Curry.ExtendedFlat.TypeInference, Curry.ExtendedFlat.MonadicGoodies + Curry.ExtendedFlat.Type, Curry.ExtendedFlat.Goodies, Curry.ExtendedFlat.TypeInference, + Curry.ExtendedFlat.MonadicGoodies, Curry.ExtendedFlat.UnMutual, Curry.ExtendedFlat.LiftLetrec Curry.FlatCurry.Type, Curry.FlatCurry.Goodies, Curry.FlatCurry.Tools Curry.Files.Filenames, Curry.Files.PathUtils