curry-base 0.2.3 → 0.2.4

raw patch · 7 files changed

+374/−7 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Curry/Base/MessageMonad.hs +7/−4
• Curry/ExtendedFlat/LiftLetrec.hs +98/−0
• Curry/ExtendedFlat/MonadicGoodies.hs +6/−0
• Curry/ExtendedFlat/TypeInference.hs +11/−0
• Curry/ExtendedFlat/UnMutual.hs +238/−0
• Curry/Files/Filenames.hs +10/−0
• curry-base.cabal +4/−3

@@ -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

@@ -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

@@ -1,3 +1,9 @@+{-+  Monadic transformations of ExtendedFlat programs.++  (c) 2009, Holger Siegel.+-}+ module Curry.ExtendedFlat.MonadicGoodies     (UpdateM, postOrderM,      updFuncExpsM, updProgFuncsM, updFuncLetsM) where

@@ -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,

@@ -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)+++

@@ -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

@@ -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