Case lifter produces shorter and unique names for lifted functions

src/Control/Monad/State.curry

+module Control.Monad.State where 
+
+data State s a =  State (s -> (a, s))
+
+{- 
+instance Applicative (State s) where
+        pure x = State (\s -> (x,s))
+        (State ff) <*> (State g) =  State (\s -> let (f,s1) = ff s
+                                                     (a,s2) = g s1
+                                                     result = (f a,s2)
+                                                 in  result)
+
+-}
+instance Functor (State s) where
+  fmap f (State g) = State $ \s -> let (a,s1) = g s in (f a,s1)
+
+
+instance Monad (State s) where
+  return x = state (\s -> (x, s))
+  m >>= f = state (\s -> let (x, s') = runState m s
+                         in runState (f x) s')
+
+
+
+runState :: State s a ->  (s -> (a,s))
+runState (State st)  = st  
+
+state :: (s -> (a, s)) -> State s a
+state = State
+
+get :: State s s
+get = state (\s -> (s, s))
+
+put :: s -> State s ()
+put s = state (\_ -> ((), s))
+
+modify :: (s -> s) -> State s ()
+modify f = state (\s -> ((), f s))
+
+evalState :: State s a -> s -> a
+evalState m s = fst (runState m s)
+
+execState :: State s a -> s -> s
+execState m s = snd (runState m s)

src/FlatCurry/CaseLifting.curry

@@ -14,7 +14,8 @@ module FlatCurry.CaseLifting where
 
 import List ( maximum, union )
 
-import FlatCurry.Goodies ( allVars )
+import Control.Monad.State
+import FlatCurry.Goodies   ( allVars, funcName )
 import FlatCurry.Types
 
 ------------------------------------------------------------------------------
@@ -22,122 +23,164 @@ import FlatCurry.Types
 data LiftOptions = LiftOptions
   { liftCase :: Bool -- lift nested cases?
   , liftCArg :: Bool -- lift non-variable case arguments?
-  , currFun  :: QName -- name of current function to be lifted (internally used)
   }
 
 --- Default options for lifting all nested case/let/free expressions.
 defaultLiftOpts :: LiftOptions
-defaultLiftOpts = LiftOptions True True ("","")
+defaultLiftOpts = LiftOptions True True
 
 --- Default options for lifting no nested case/let/free expression.
 defaultNoLiftOpts :: LiftOptions
-defaultNoLiftOpts = LiftOptions False False ("","")
+defaultNoLiftOpts = LiftOptions False False
 
--- Add suffix to case function
-addSuffix2Fun :: LiftOptions -> String -> LiftOptions
-addSuffix2Fun opts suff =
-  let (mn,fn) = currFun opts
-  in opts { currFun = (mn, fn ++ suff) }
+------------------------------------------------------------------------------
+--- Options for case/let/free lifting.
+data LiftState = LiftState
+  { liftOpts  :: LiftOptions -- lifting options
+  , currMod   :: String      -- name of current module
+  , topFuncs  :: [String]    -- name of all origin top-level functions
+  , liftFuncs :: [FuncDecl]  -- new functions generated by lifting
+  , currFunc  :: String      -- name of current top-level function to be lifted
+  , currIndex :: Int         -- index for generating new function names
+  }
+
+type LiftingState a = State LiftState a
+
+-- Get lifting options from current state.
+getOpts :: LiftingState LiftOptions
+getOpts = get >>= return . liftOpts
+
+-- Create a new function name from the current function w.r.t. a suffix.
+genFuncName :: String -> LiftingState QName
+genFuncName suffix = do
+  st <- get
+  let newfn = currFunc st ++ '_' : suffix ++ show (currIndex st)
+  put st { currIndex = currIndex st + 1 }
+  if newfn `elem` topFuncs st
+    then genFuncName suffix
+    else return (currMod st, newfn)
+
+-- Modify a state by adding a function declaration.
+addFun2State :: FuncDecl -> LiftState -> LiftState
+addFun2State fd st = st { liftFuncs = fd : liftFuncs st }
 
 ------------------------------------------------------------------------------
 
 --- Lift nested cases/lets/free in a FlatCurry program (w.r.t. options).
 liftProg :: LiftOptions -> Prog -> Prog
 liftProg opts (Prog mn imps types funs ops) =
-  Prog mn imps types (concatMap (liftFun opts) funs) ops
-
---- Lift nested cases/lets/free in a FlatCurry function (w.r.t. options).
-liftFun :: LiftOptions -> FuncDecl -> [FuncDecl]
-liftFun opts (Func fn ar vis texp rule) =
-  let (nrule, nfs) = liftRule opts { currFun = fn } rule
-  in Func fn ar vis texp nrule : nfs
-
-
-liftRule :: LiftOptions -> Rule -> (Rule, [FuncDecl])
-liftRule _ (External n) = (External n, [])
-liftRule opts (Rule args rhs) =
-  let (nrhs, nfs) = liftExp opts False rhs
-  in (Rule args nrhs, nfs)
+  let alltopfuns = map (snd . funcName) funs
+      initstate  = LiftState opts mn alltopfuns [] "" 0
+      transfuns  = evalState (mapM liftTopFun funs) initstate
+  in Prog mn imps types (concat transfuns) ops
+
+-- Lift top-level function.
+liftTopFun :: FuncDecl -> LiftingState [FuncDecl]
+liftTopFun (Func fn ar vis texp rule) = do
+  st0 <- get
+  put st0 { currFunc = snd fn, currIndex = 0 }
+  nrule <- liftRule rule
+  st <- get
+  put st { liftFuncs = [] }
+  return $ Func fn ar vis texp nrule : liftFuncs st
+
+-- Lift newly introduced function.
+liftNewFun :: FuncDecl -> LiftingState FuncDecl
+liftNewFun (Func fn ar vis texp rule) = do
+  nrule <- liftRule rule
+  return $ Func fn ar vis texp nrule
+
+liftRule :: Rule -> LiftingState Rule
+liftRule (External n)    = return (External n)
+liftRule (Rule args rhs) = do
+  nrhs <- liftExp False rhs
+  return (Rule args nrhs)
 
 -- Lift nested cases/lets/free in expressions.
 -- If the second argument is `True`, we are inside an expression where
 -- lifting is necessary (e.g., in arguments of function calls).
-liftExp :: LiftOptions -> Bool -> Expr -> (Expr, [FuncDecl])
-liftExp _ _ (Var v) = (Var v, [])
-liftExp _ _ (Lit l) = (Lit l, [])
-liftExp opts _ (Comb ct qn es) =
-  let (nes,nfs) = unzip (map (\ (n,e) -> liftExpArg opts True n e)
-                             (zip [1..] es))
-  in (Comb ct qn nes, concat nfs)
-
-liftExp opts nested exp@(Case ct e brs) = case e of
-  Var _ -> liftCaseExp
-  _     -> if liftCArg opts then liftCaseArg else liftCaseExp
+liftExp :: Bool -> Expr -> LiftingState Expr
+liftExp _ (Var v) = return (Var v)
+liftExp _ (Lit l) = return (Lit l)
+liftExp _ (Comb ct qn es) = do
+  nes <- mapM (liftExp True) es
+  return (Comb ct qn nes)
+
+liftExp nested exp@(Case ct e brs) = do
+  opts <- getOpts
+  case e of
+    Var _ -> liftCaseExp
+    _     -> if liftCArg opts then liftCaseArg else liftCaseExp
  where
-  liftCaseExp =
+  liftCaseExp = do
     if nested -- lift case expression by creating new function
-      then let vs       = unboundVars exp
-               cfn      = currFun (addSuffix2Fun opts "$CASE")
-               noneType = TCons ("Prelude","None") []
-               caseFunc = Func cfn (length vs) Private noneType (Rule vs exp)
-           in (Comb FuncCall cfn (map Var vs), liftFun opts caseFunc)
-      else let (ne, nefs) = liftExpArg opts True 0 e
-               (nbrs, nfs) = unzip (map (liftBranch opts) (zip [1..] brs))
-           in (Case ct ne nbrs, nefs ++ concat nfs)
+      then do
+        cfn <- genFuncName "CASE"
+        let vs       = unboundVars exp
+            noneType = TCons ("Prelude","None") []
+            caseFunc = Func cfn (length vs) Private noneType (Rule vs exp)
+        casefun <- liftNewFun caseFunc
+        modify (addFun2State casefun)
+        return $ Comb FuncCall cfn (map Var vs)
+      else do
+        ne <- liftExp True e
+        nbrs <- mapM liftBranch brs
+        return $ Case ct ne nbrs
+
+  liftBranch (Branch pat be) = do
+    opts <- getOpts
+    ne   <- liftExp (liftCase opts) be
+    return (Branch pat ne)
 
   -- lift case with complex (non-variable) case argument:
-  liftCaseArg =
-    let (ne, nefs) = liftExpArg opts True 0 e
-        casevar    = maximum (0 : allVars exp) + 1
+  liftCaseArg = do
+    ne  <- liftExp True e
+    cfn <- genFuncName "COMPLEXCASE"
+    let casevar    = maximum (0 : allVars exp) + 1
         vs         = unionMap unboundVarsInBranch brs
-        cfn        = currFun (addSuffix2Fun opts "$COMPLEXCASE")
         noneType   = TCons ("Prelude","None") []
         caseFunc   = Func cfn (length vs + 1) Private noneType
                           (Rule (vs ++ [casevar]) (Case ct (Var casevar) brs))
-    in (Comb FuncCall cfn (map Var vs ++ [ne]), nefs ++ liftFun opts caseFunc)
+    casefun <- liftNewFun caseFunc
+    modify (addFun2State casefun)
+    return $ Comb FuncCall cfn (map Var vs ++ [ne])
 
-liftExp opts nested exp@(Let bs e)
+liftExp nested exp@(Let bs e)
  | nested -- lift nested let expressions by creating new function
- = let vs       = unboundVars exp
-       cfn      = currFun (addSuffix2Fun opts "$LET")
-       noneType = TCons ("Prelude","None") []
-       letFunc  = Func cfn (length vs) Private noneType (Rule vs exp)
-   in (Comb FuncCall cfn (map Var vs), liftFun opts letFunc)
+ = do cfn <- genFuncName "LET"
+      let vs       = unboundVars exp
+          noneType = TCons ("Prelude","None") []
+          letFunc  = Func cfn (length vs) Private noneType (Rule vs exp)
+      letfun <- liftNewFun letFunc
+      modify (addFun2State letfun)
+      return $ Comb FuncCall cfn (map Var vs)
  | otherwise
- = let (nes,nfs1) = unzip (map (\ (n,be) -> liftExpArg opts True n be)
-                          (zip [1..] (map snd bs)))
-       (ne,nfs2)  = liftExpArg opts True 0 e
-   in (Let (zip (map fst bs) nes) ne, concat nfs1 ++ nfs2)
+ = do nes <- mapM (liftExp True) (map snd bs)
+      ne <- liftExp True e
+      return $ Let (zip (map fst bs) nes) ne
 
-liftExp opts nested exp@(Free vs e)
+liftExp nested exp@(Free vs e)
  | nested -- lift nested free declarations by creating new function
- = let fvs      = unboundVars exp
-       cfn      = currFun (addSuffix2Fun opts "$FREE")
-       noneType = TCons ("Prelude","None") []
-       freeFunc = Func cfn (length fvs) Private noneType (Rule fvs exp)
-   in (Comb FuncCall cfn (map Var fvs), liftFun opts freeFunc)
+ = do cfn <- genFuncName "FREE"
+      let fvs      = unboundVars exp
+          noneType = TCons ("Prelude","None") []
+          freeFunc = Func cfn (length fvs) Private noneType (Rule fvs exp)
+      freefun <- liftNewFun freeFunc
+      modify (addFun2State freefun)
+      return $ Comb FuncCall cfn (map Var fvs)
  | otherwise
- = let (ne, nfs) = liftExp opts True e
-   in (Free vs ne, nfs)
-
-liftExp opts _ (Or e1 e2) =
-  let (ne1, nfs1) = liftExpArg opts True 1 e1
-      (ne2, nfs2) = liftExpArg opts True 2 e2
-  in (Or ne1 ne2, nfs1 ++ nfs2)
-liftExp opts nested (Typed e te) =
-  let (ne, nfs) = liftExp opts nested e
-  in (Typed ne te, nfs)
-
--- Lift an argument of an expression so that the argument number
--- is added to the case function in order to obtain unique names.
-liftExpArg :: LiftOptions -> Bool -> Int -> Expr -> (Expr, [FuncDecl])
-liftExpArg opts nested argnum =
-  liftExp (addSuffix2Fun opts ('_' : show argnum)) nested
-
-liftBranch :: LiftOptions -> (Int,BranchExpr) -> (BranchExpr, [FuncDecl])
-liftBranch opts (bnum, Branch pat e) =
-  let (ne,nfs) = liftExpArg opts (liftCase opts) bnum e
-  in (Branch pat ne, nfs)
+ = do ne <- liftExp True e
+      return (Free vs ne)
+
+liftExp _ (Or e1 e2) = do
+  ne1 <- liftExp True e1
+  ne2 <- liftExp True e2
+  return (Or ne1 ne2)
+
+liftExp nested (Typed e te) = do
+  ne <- liftExp nested e
+  return (Typed ne te)
+
 
 --- Find all variables which are not bound in an expression.
 unboundVars :: Expr -> [VarIndex]

src/ICurry/Compiler.curry

@@ -170,9 +170,9 @@ trRule opts (Rule args rhs) = IFuncBody (toIBlock opts args rhs 0)
 
 toIBlock :: ICOptions -> [VarIndex] -> Expr -> Int -> IBlock
 toIBlock opts vs e root =
-  IBlock (map IVarDecl vs ++ varDecls)
-         (map (\ (p,i) -> IVarAssign i (IVarAccess root [p])) (zip [0..] vs) ++
-          varAssigns)
+  IBlock (map IVarDecl (filter (`elem` evars) vs) ++ varDecls)
+         (map (\ (p,i) -> IVarAssign i (IVarAccess root [p]))
+              (filter ((`elem` evars) . snd) (zip [0..] vs)) ++ varAssigns)
          (case e of
             Case _ ce brs@(Branch (Pattern _ _) _ : _) ->
               let carg = trCaseArg ce
@@ -183,6 +183,8 @@ toIBlock opts vs e root =
             Comb FuncCall fn [] | fn == pre "failed" -> IExempt
             _ -> IReturn (toIExpr opts e))
  where
+  evars = allVars e
+
   varDecls = case e of
                Free fvs _       -> map IFreeDecl fvs
                Let bs   _       -> map (IVarDecl .fst) bs
@@ -191,7 +193,7 @@ toIBlock opts vs e root =
                _                -> []
 
   -- fresh variable to translate complex case arguments:
-  caseVar = maximum (0 : allVars e) + 1
+  caseVar = maximum (0 : evars) + 1
 
   varAssigns = case e of
                  Let bs _ ->

src/ICurry/Main.curry

@@ -2,7 +2,7 @@
 --- This module contains a simple compiler from FlatCurry to ICurry programs.
 ---
 --- @author Michael Hanus
---- @version February 2020
+--- @version May 2020
 ------------------------------------------------------------------------------
 
 module ICurry.Main where
@@ -30,7 +30,7 @@ testI p =
 banner :: String
 banner = unlines [bannerLine,bannerText,bannerLine]
  where
-   bannerText = "ICurry Compiler (Version of 19/02/20)"
+   bannerText = "ICurry Compiler (Version of 12/05/20)"
    bannerLine = take (length bannerText) (repeat '=')
 
 main :: IO ()

src/ICurry/Pretty.curry

@@ -7,7 +7,7 @@
 
 module ICurry.Pretty where
 
-import List ( intersperse )
+import List ( intercalate, intersperse )
 
 import ICurry.Types
 import Text.Pretty
@@ -76,7 +76,12 @@ ppFunctions = vsepBlank . map ppFunction
 --- @param fns the function
 --- @return    the pretty printed function
 ppFunction :: IFunction -> Doc
-ppFunction (IFunction name _ _ _ body) = ppQName name <+> ppFuncBody body
+ppFunction (IFunction name ar _ demargs body) =
+  ppQName name <> char '/' <> int ar <>
+  (if null demargs
+     then empty
+     else text (" (DEMANDED: " ++ intercalate "," (map show demargs) ++ ")"))
+  <+> char ':' <+> ppFuncBody body
 
 --- Pretty print a qualified ICurry name (module.localname)
 --- @param name the name
@@ -88,8 +93,8 @@ ppQName (modname, localname, _) = text $ modname ++ '.' : localname
 --- @param body the function's body
 --- @return     the pretty printed function body
 ppFuncBody :: IFuncBody -> Doc
-ppFuncBody (IExternal name) = text ("external \"" ++ name ++ "\",")
-ppFuncBody (IFuncBody block) = equals <+> ppBlock block
+ppFuncBody (IExternal name)  = text ("external \"" ++ name ++ "\",")
+ppFuncBody (IFuncBody block) = ppBlock block
 
 --- Pretty print a list of variables
 --- @param vs the variables