1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

------------------------------------------------------------------------------
--- Right-linearity analysis:
--- check whether functions are defined by right-linear rules.
---
--- @author Michael Hanus
--- @version April 2013
------------------------------------------------------------------------------

module Analysis.RightLinearity
  (rlinAnalysis,hasRightLinearRules,linearExpr,showRightLinear) where

import Analysis.Types
import FlatCurry.Types
import Data.Maybe
import Data.List

------------------------------------------------------------------------------
--- The right-linearity analysis is a global function dependency analysis.
--- It assigns to a function a flag which is True if this function
--- is right-linear, i.e., defined by right-linear rules and depend only on
--- functions defined by right-linear rules.

rlinAnalysis :: Analysis Bool
rlinAnalysis = dependencyFuncAnalysis "RightLinear" True rlFunc

--- An operation is right-linear if it is defined by right-linear rules
--- and depends only on right-linear operations.
rlFunc  :: FuncDecl -> [(QName,Bool)] -> Bool
rlFunc func calledFuncs =
  hasRightLinearRules func && all snd calledFuncs

-- Show right-linearity information as a string.
showRightLinear :: AOutFormat -> Bool -> String
showRightLinear _     True  = "right-linear"
showRightLinear AText False = "not defined by right-linear rules"
showRightLinear ANote False = ""

------------------------------------------------------------------------------
-- The right-linearity analysis can also be applied to individual functions.
-- It returns True for a function if it is defined by right-linear rules.

hasRightLinearRules :: FuncDecl -> Bool
hasRightLinearRules (Func _ _ _ _ rule) = isRightLinearRule rule

isRightLinearRule :: Rule -> Bool
isRightLinearRule (Rule _ e)   = linearExpr e
isRightLinearRule (External _) = True

--------------------------------------------------------------------------
-- Check an expression for linearity:
linearExpr :: Expr -> Bool
linearExpr e = maybe False (const True) (linearVariables e)

-- Return list of variables in an expression, if it is linear,
-- otherwise: Nothing
linearVariables :: Expr -> Maybe [Int]
linearVariables (Var i) = Just [i]
linearVariables (Lit _) = Just []
linearVariables (Comb _ f es)
 | f==("Prelude","?") && length es == 2  -- treat "?" as Or:
  = linearVariables (Or (head es) (head (tail es)))
 | otherwise
  = mapM linearVariables es >>= \esvars ->
    let vars = concat esvars
     in if nub vars == vars
        then Just vars
        else Nothing
linearVariables (Free vs e) =
  linearVariables e >>= \evars -> Just (evars \\ vs)
linearVariables (Let bs e) =
  mapM linearVariables (map snd bs) >>= \bsvars ->
  linearVariables e >>= \evars ->
  let vars = concat (evars : bsvars)
   in if nub vars == vars
      then Just (vars \\ (map fst bs))
      else Nothing
linearVariables (Or e1 e2) =
  linearVariables e1 >>= \e1vars ->
  linearVariables e2 >>= \e2vars ->
  Just (union e1vars e2vars)
linearVariables (Case _ e bs) =
  linearVariables e >>= \evars ->
  mapM linearVariables (map (\ (Branch _ be) -> be) bs) >>= \bsvars ->
  let vars = foldr union [] (map (\ (branch,bsv) -> bsv \\ patternVars branch)
                                 (zip bs bsvars)) ++ evars
   in if nub vars == vars
      then Just vars
      else Nothing
 where
  patternVars (Branch (Pattern _ vs) _) = vs
  patternVars (Branch (LPattern _)   _) = []
linearVariables (Typed e _) = linearVariables e