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
93
94
95
96
97
98
99
100
101
102
103
104

------------------------------------------------------------------------------
--- Demandedness analysis:
--- checks whether functions demands a particular argument, i.e.,
--- delivers only bottom if some argument is bottom.
---
--- @author Michael Hanus
--- @version May 2013
------------------------------------------------------------------------------

module Analysis.Demandedness
 where

import Analysis.Types
import FlatCurry.Types
import FlatCurry.Goodies
import List((\\),intercalate)

------------------------------------------------------------------------------
--- Data type to represent information about demanded arguments.
--- Demanded arguments are represented as a list of indices
--- for the arguments, where arguments are numbered from 1.
type DemandedArgs = [Int]

-- Show determinism information as a string.
showDemand :: AOutFormat -> DemandedArgs -> String
showDemand AText []     = "no demanded arguments"
showDemand ANote []     = ""
showDemand fmt (x:xs) =
  (if fmt==AText then "demanded arguments: " else "") ++
  intercalate "," (map show (x:xs))

-- Abstract demand domain.
data DemandDomain = Bot | Top
  deriving Eq

-- Least upper bound on abstract demand domain.
lub :: DemandDomain -> DemandDomain -> DemandDomain
lub Bot x = x
lub Top _ = Top

--- Demandedness analysis.
demandAnalysis :: Analysis DemandedArgs
demandAnalysis = dependencyFuncAnalysis "Demand" [1..] daFunc

-- We define the demanded arguments of some primitive prelude operations.
-- Otherwise, we analyse the right-hand sides of the rule.
daFunc :: FuncDecl -> [(QName,DemandedArgs)] -> DemandedArgs
daFunc (Func (m,f) _ _ _ rule) calledFuncs
 | f `elem` prelude2s && m==prelude = [1,2]
 | f `elem` prelude1s && m==prelude = [1]
 | otherwise = daFuncRule calledFuncs rule
 where
  prelude2s = ["==","=:=","compare","<=","$#","$##","$!","$!!",
               "+","-","*","div","mod","divMod","quot","rem","quotRem"]
  prelude1s = ["seq","ensureNotFree","apply","cond","=:<=","negateFloat"]
 -- TODO: >>= catch catchFail


daFuncRule :: [(QName,DemandedArgs)] -> Rule -> DemandedArgs
daFuncRule _ (External _) = [] -- nothing known about other externals
daFuncRule calledFuncs (Rule args rhs) =
  map fst
      (filter ((==Bot) . snd)
              (map (\botarg -> (botarg, absEvalExpr rhs [botarg]))
                   args))
 where
  -- abstract evaluation of an expression w.r.t. variables assumed to be Bot
  absEvalExpr (Var i)        bvs = if i `elem` bvs then Bot else Top
  absEvalExpr (Lit _)        _   = Top
  absEvalExpr (Comb ct g es) bvs =
    if ct == FuncCall
    then
      if g == (prelude,"failed")
      then Bot -- Prelude.failed never returns a value
      else maybe (error $ "Abstract value of " ++ show g ++ " not found!")
                 (\gdas -> let curargs = map (\ (i,e) -> (i,absEvalExpr e bvs))
                                             (zip [1..] es)
                               cdas = gdas \\
                                      map fst (filter ((/=Bot) . snd) curargs)
                            in if null cdas then Top else Bot)
                 (lookup g calledFuncs)
    else Top
  absEvalExpr (Free _ e)     bvs = absEvalExpr e bvs
  absEvalExpr (Let bs e)     bvs = absEvalExpr e (absEvalBindings bs bvs)
  absEvalExpr (Or e1 e2)     bvs = lub (absEvalExpr e1 bvs) (absEvalExpr e2 bvs)
  absEvalExpr (Case _  e bs) bvs =
    if absEvalExpr e bvs == Bot
    then Bot
    else foldr lub Bot (map absEvalBranch bs)
   where absEvalBranch (Branch _ be) = absEvalExpr be bvs
  absEvalExpr (Typed e _) bvs = absEvalExpr e bvs

    -- could be improved with local fixpoint computation
  absEvalBindings [] bvs = bvs
  absEvalBindings ((i,exp) : bs) bvs =
    let ival = absEvalExpr exp bvs
     in if ival==Bot
        then absEvalBindings bs (i:bvs)
        else absEvalBindings bs bvs

prelude :: String
prelude = "Prelude"

------------------------------------------------------------------------------