ghc/compiler/usageSP/UConSet.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[UConSet]{UsageSP constraint solver}
   5
   6 This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
   7 February 1998 .. April 1999.
   8
   9 Keith Wansbrough 1998-02-16..1999-04-29
  10
  11 \begin{code}
  12 module UConSet ( UConSet,
  13                  emptyUConSet,
  14                  eqManyUConSet,
  15                  eqUConSet,
  16                  leqUConSet,
  17                  unionUCS,
  18                  unionUCSs,
  19                  solveUCS,
  20                ) where
  21
  22 #include "HsVersions.h"
  23
  24 import VarEnv
  25 import Type             ( UsageAnn(..) )
  26 import Var              ( UVar )
  27 import Bag              ( Bag, unitBag, emptyBag, unionBags, foldlBag, bagToList )
  28 import Outputable
  29 import PprType
  30 \end{code}
  31
  32 ======================================================================
  33
  34 The data type:
  35 ~~~~~~~~~~~~~~
  36
  37 First, individual constraints on particular variables.  This is
  38 private to the implementation.
  39
  40 \begin{code}
  41 data UCon = UCEq           UVar UVar    --         j = k  (equivalence)
  42           | UCBound [UVar] UVar [UVar]  -- {..} <= j <= {..}
  43           | UCUsOnce       UVar         --         j = 1
  44           | UCUsMany       UVar         --         j = omega
  45 \end{code}
  46
  47 Next, the public (but abstract) data type for a usage constraint set:
  48 either a bag of mappings from @UVar@ to @UCon@, or an error message
  49 for an inconsistent constraint set.
  50
  51 \begin{code}
  52 data UConSet = UConSet (Bag (VarEnv UCon))
  53              | UConFail SDoc
  54 \end{code}
  55
  56 The idea is that the @VarEnv@s (which will eventually be merged into a
  57 single @VarEnv@) are union-find data structures: a variable is either
  58 equal to another variable, or it is bounded or has a value.  The
  59 equalities form a forest pointing to a root node for each equality
  60 class, on which is found the bound or value for that class.
  61
  62 The @Bag@ enables two-phase operation: we merely collect constraints
  63 in the first phase, an donly union them at solution time.  This gives
  64 a much more efficient algorithm, as we make only a single pass over
  65 the constraints.
  66
  67 Note that the absence of a variable from the @VarEnv@ is exactly
  68 equivalent to it being mapped to @UCBound [] _ []@.
  69
  70
  71 The interface:
  72 ~~~~~~~~~~~~~~
  73
  74 @emptyUConSet@ gives an empty constraint set.
  75 @eqManyUConSet@ constrains an annotation to be Many.
  76 @eqUConSet@ constrains two annotations to be equal.
  77 @leqUConSet@ constrains one annotation to be less than or equal to
  78 another (with Once < Many).
  79
  80 \begin{code}
  81 mkUCS = UConSet . unitBag  -- helper function not exported
  82
  83 emptyUConSet :: UConSet
  84 emptyUConSet  = UConSet emptyBag
  85
  86 eqManyUConSet :: UsageAnn -> UConSet
  87
  88 eqManyUConSet UsOnce     = UConFail (text "Once /= Many")
  89 eqManyUConSet UsMany     = emptyUConSet
  90 eqManyUConSet (UsVar uv) = mkUCS $ unitVarEnv uv (UCUsMany uv)
  91
  92 eqUConSet :: UsageAnn -> UsageAnn -> UConSet
  93
  94 eqUConSet UsOnce     UsOnce      = emptyUConSet
  95 eqUConSet UsOnce     (UsVar uv)  = mkUCS $ unitVarEnv uv (UCUsOnce uv)
  96 eqUConSet UsMany     UsMany      = emptyUConSet
  97 eqUConSet UsMany     (UsVar uv)  = mkUCS $ unitVarEnv uv (UCUsMany uv)
  98 eqUConSet (UsVar uv) UsOnce      = mkUCS $ unitVarEnv uv (UCUsOnce uv)
  99 eqUConSet (UsVar uv) UsMany      = mkUCS $ unitVarEnv uv (UCUsMany uv)
 100 eqUConSet (UsVar uv) (UsVar uv') = if uv==uv'
 101                                    then emptyUConSet
 102                                    else mkUCS $ unitVarEnv uv (UCEq uv uv')
 103 eqUConSet UsMany     UsOnce      = UConFail (text "Many /= Once")
 104 eqUConSet UsOnce     UsMany      = UConFail (text "Once /= Many")
 105
 106 leqUConSet :: UsageAnn -> UsageAnn -> UConSet
 107
 108 leqUConSet UsOnce     _           = emptyUConSet
 109 leqUConSet _          UsMany      = emptyUConSet
 110 leqUConSet UsMany     UsOnce      = UConFail (text "Many /<= Once")
 111 leqUConSet UsMany     (UsVar uv)  = mkUCS $ unitVarEnv uv (UCUsMany uv)
 112 leqUConSet (UsVar uv) UsOnce      = mkUCS $ unitVarEnv uv (UCUsOnce uv)
 113 leqUConSet (UsVar uv) (UsVar uv') = mkUCS $ mkVarEnv [(uv, UCBound []   uv  [uv']),
 114                                                       (uv',UCBound [uv] uv' []   )]
 115 \end{code}
 116
 117 @unionUCS@ forms the union of two @UConSet@s.
 118 @unionUCSs@ forms the `big union' of a list of @UConSet@s.
 119
 120 \begin{code}
 121 unionUCS :: UConSet -> UConSet -> UConSet
 122
 123 unionUCS     (UConSet b1)      (UConSet b2) = UConSet (b1 `unionBags` b2)
 124 unionUCS ucs@(UConFail _)                _  = ucs  -- favour first error
 125 unionUCS     (UConSet  _)  ucs@(UConFail _) = ucs
 126
 127 unionUCSs :: [UConSet] -> UConSet
 128
 129 unionUCSs ucss = foldl unionUCS emptyUConSet ucss
 130 \end{code}
 131
 132
 133 @solveUCS@ finds the minimal solution to the constraint set, returning
 134 it as @Just@ a substitution function taking usage variables to usage
 135 annotations (@UsOnce@ or @UsMany@).  If this is not possible (for an
 136 inconsistent constraint set), @solveUCS@ returns @Nothing@.
 137
 138 The minimal solution is found by simply reading off the known
 139 variables, and for unknown ones substituting @UsOnce@.
 140
 141 \begin{code}
 142 solveUCS :: UConSet -> Maybe (UVar -> UsageAnn)
 143
 144 solveUCS (UConSet css)
 145   = case foldlBag (\cs1 jcs2 -> foldVarEnv addUCS cs1 jcs2)
 146                   (Left emptyVarEnv)
 147                   css of
 148       Left cs   -> let cs'    = mapVarEnv conToSub cs
 149                        sub uv = case lookupVarEnv cs' uv of
 150                                   Just u  -> u
 151                                   Nothing -> UsOnce
 152                        conToSub (UCEq       _ uv')    = case lookupVarEnv cs uv' of
 153                                                           Nothing   -> UsOnce
 154                                                           Just con' -> conToSub con'
 155                        conToSub (UCUsOnce   _    )    = UsOnce
 156                        conToSub (UCUsMany   _    )    = UsMany
 157                        conToSub (UCBound  _ _ _  )    = UsOnce
 158                    in  Just sub
 159       Right err -> solveUCS (UConFail err)
 160
 161 solveUCS (UConFail why) =
 162 #ifdef DEBUG
 163                           pprTrace "UConFail:" why $
 164 #endif
 165                           Nothing
 166 \end{code}
 167
 168 ======================================================================
 169
 170 The internals:
 171 ~~~~~~~~~~~~~~
 172
 173 In the internals, we use the @VarEnv UCon@ explicitly, or occasionally
 174 @Either (VarEnv UCon) SDoc@.  In other words, the @Bag@ is no longer
 175 used.
 176
 177 @findUCon@ finds the root of an equivalence class.
 178 @changeUConUVar@ copies a constraint, but changes the variable constrained.
 179
 180 \begin{code}
 181 findUCon :: VarEnv UCon -> UVar -> UVar
 182
 183 findUCon cs uv
 184   = case lookupVarEnv cs uv of
 185       Just (UCEq _ uv') -> findUCon cs uv'
 186       Just _            -> uv
 187       Nothing           -> uv
 188
 189 changeUConUVar :: UCon -> UVar -> UCon
 190
 191 changeUConUVar (UCEq       _ v ) uv' = (UCEq       uv' v )
 192 changeUConUVar (UCBound us _ vs) uv' = (UCBound us uv' vs)
 193 changeUConUVar (UCUsOnce   _   ) uv' = (UCUsOnce   uv'   )
 194 changeUConUVar (UCUsMany   _   ) uv' = (UCUsMany   uv'   )
 195 \end{code}
 196
 197 @mergeUVars@ tests to see if a set of @UVar@s can be constrained.  If
 198 they can, it returns the set of root @UVar@s represented (with no
 199 duplicates); if they can't, it returns @Nothing@.
 200
 201 \begin{code}
 202 mergeUVars :: VarEnv UCon    -- current constraint set
 203            -> Bool           -- True/False = try to constrain to Many/Once
 204            -> [UVar]         -- list of UVars to constrain
 205            -> Maybe [UVar]   -- Just [root uvars to force], or Nothing if conflict
 206
 207 mergeUVars cs isMany vs = foldl muv (Just []) vs
 208   where
 209     muv :: Maybe [UVar] -> UVar -> Maybe [UVar]
 210     muv Nothing      _
 211       = Nothing
 212     muv jvs@(Just vs) v
 213       = let rv = findUCon cs v
 214         in  if elem rv vs
 215             then
 216               jvs
 217             else
 218               case lookupVarEnv cs rv of  -- never UCEq
 219                 Nothing              -> Just (rv:vs)
 220                 Just (UCBound _ _ _) -> Just (rv:vs)
 221                 Just (UCUsOnce _)    -> if isMany then Nothing else jvs
 222                 Just (UCUsMany _)    -> if isMany then jvs else Nothing
 223 \end{code}
 224
 225 @addUCS@ adds an individual @UCon@ on a @UVar@ to a @UConSet@.  This
 226 is the core of the algorithm.  As such, it could probably use some
 227 optimising.
 228
 229 \begin{code}
 230 addUCS :: UCon                        -- constraint to add
 231        -> Either (VarEnv UCon) SDoc   -- old constraint set or error
 232        -> Either (VarEnv UCon) SDoc   -- new constraint set or error
 233
 234 addUCS _ jcs@(Right _) = jcs  -- propagate errors
 235
 236 addUCS (UCEq uv1 uv2) jcs@(Left cs)
 237   = let ruv1 = findUCon cs uv1
 238         ruv2 = findUCon cs uv2
 239     in  if ruv1==ruv2
 240         then jcs  -- no change if already equal
 241         else let cs' = Left $ extendVarEnv cs ruv1 (UCEq ruv1 ruv2)  -- merge trees
 242              in  case lookupVarEnv cs ruv1 of
 243                    Just uc'
 244                      -> addUCS (changeUConUVar uc' ruv2) cs'  -- merge old constraints
 245                    Nothing
 246                      -> cs'
 247
 248 addUCS (UCBound us uv1 vs) jcs@(Left cs)
 249   = let ruv1 = findUCon cs uv1
 250     in  case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of  -- never UCEq
 251           UCBound us' _ vs'
 252             -> case (mergeUVars cs False (us'++us),
 253                      mergeUVars cs True  (vs'++vs)) of
 254                  (Just us'',Just vs'')  -- update
 255                    -> Left $ extendVarEnv cs ruv1 (UCBound us'' ruv1 vs'')
 256                  (Nothing,  Just vs'')  -- set
 257                    -> addUCS (UCUsMany ruv1)
 258                              (forceUVars UCUsMany vs'' jcs)
 259                  (Just us'',Nothing)    -- set
 260                    -> addUCS (UCUsOnce ruv1)
 261                              (forceUVars UCUsOnce us'' jcs)
 262                  (Nothing,  Nothing)    -- fail
 263                    -> Right (text "union failed[B] at" <+> ppr uv1)
 264           UCUsOnce _
 265             -> forceUVars UCUsOnce us jcs
 266           UCUsMany _
 267             -> forceUVars UCUsMany vs jcs
 268
 269 addUCS (UCUsOnce uv1) jcs@(Left cs)
 270   = let ruv1 = findUCon cs uv1
 271     in  case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of  -- never UCEq
 272           UCBound us _ vs
 273             -> forceUVars UCUsOnce us (Left $ extendVarEnv cs ruv1 (UCUsOnce ruv1))
 274           UCUsOnce _
 275             -> jcs
 276           UCUsMany _
 277             -> Right (text "union failed[O] at" <+> ppr uv1)
 278
 279 addUCS (UCUsMany uv1) jcs@(Left cs)
 280   = let ruv1 = findUCon cs uv1
 281     in  case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of  -- never UCEq
 282           UCBound us _ vs
 283             -> forceUVars UCUsMany vs (Left $ extendVarEnv cs ruv1 (UCUsMany ruv1))
 284           UCUsOnce _
 285             -> Right (text "union failed[M] at" <+> ppr uv1)
 286           UCUsMany _
 287             -> jcs
 288
 289 -- helper function forcing a set of UVars to either Once or Many:
 290 forceUVars :: (UVar -> UCon)
 291            -> [UVar]
 292            -> Either (VarEnv UCon) SDoc
 293            -> Either (VarEnv UCon) SDoc
 294 forceUVars uc uvs cs0 = foldl (\cs uv -> addUCS (uc uv) cs) cs0 uvs
 295 \end{code}
 296
 297 ======================================================================
 298
 299 Pretty-printing:
 300 ~~~~~~~~~~~~~~~~
 301
 302 \begin{code}
 303 -- Printing a usage constraint.
 304
 305 pprintUCon :: VarEnv UCon -> UCon -> SDoc
 306
 307 pprintUCon fm (UCEq uv1 uv2)
 308   = ppr uv1 <+> text "=" <+> ppr uv2 <> text ":"
 309     <+> let uv2' = findUCon fm uv2
 310         in  case lookupVarEnv fm uv2' of
 311               Just uc -> pprintUCon fm uc
 312               Nothing -> text "unconstrained"
 313
 314 pprintUCon fm (UCBound us uv vs)
 315   = lbrace <> hcat (punctuate comma (map ppr us)) <> rbrace
 316     <+> text "<=" <+> ppr uv <+> text "<="
 317     <+> lbrace <> hcat (punctuate comma (map ppr vs)) <> rbrace
 318
 319 pprintUCon fm (UCUsOnce uv)
 320   = ppr uv <+> text "=" <+> ppr UsOnce
 321
 322 pprintUCon fm (UCUsMany uv)
 323   = ppr uv <+> text "=" <+> ppr UsMany
 324
 325 -- Printing a usage constraint set.
 326
 327 instance Outputable UConSet where
 328   ppr (UConSet bfm)
 329     = text "UConSet:" <+> lbrace
 330       $$ vcat (map (\fm -> nest 2 (vcat (map (pprintUCon fm) (rngVarEnv fm))))
 331                    (bagToList bfm))
 332       $$ rbrace
 333
 334   ppr (UConFail d)
 335     = hang (text "UConSet inconsistent:")
 336         4 d
 337 \end{code}
 338
 339 ======================================================================
 340
 341 EOF