ghc/compiler/deforest/Cyclic.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Cyclic]{Knot tying}
   5
   6 >#include "HsVersions.h"
   7 >
   8 > module Cyclic (
   9 >       mkLoops, fixupFreeVars
  10 >       ) where
  11
  12 > import DefSyn
  13 > import DefUtils
  14 > import Def2Core       ( d2c, defPanic )
  15
  16 > import Type           ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTys,
  17 >                         TyVarTemplate
  18 >                       )
  19 > import Digraph        ( dfs )
  20 > import Id             ( idType, toplevelishId, updateIdType,
  21 >                         getIdInfo, replaceIdInfo, eqId, Id
  22 >                       )
  23 > import IdInfo
  24 > import Outputable
  25 > import Pretty
  26 > import UniqSupply
  27 > import Util
  28
  29 -----------------------------------------------------------------------------
  30 A more efficient representation for lists that are extended multiple
  31 times, but only examined once.
  32
  33 > type FList a  = [a] -> [a]
  34 > append        = (.)
  35 > singleton x   = (x:)
  36 > cons x xs     = \ys -> x:(xs ys)
  37 > list x        = (x++)
  38 > emptylist     = id
  39
  40 -----------------------------------------------------------------------------
  41 Monad for the knot-tier.
  42
  43 > type Lbl a = UniqSM (
  44 >       [(Id)],                         -- loops used
  45 >       [(Id,DefExpr,[Id],DefExpr)],    -- bindings floating upwards
  46 >       [(Id,DefExpr)],                 -- back loops
  47 >       a)                              -- computation result
  48 >
  49 > thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b
  50 > thenLbl a k
  51 >       = a     `thenUs` \(ls, bs, bls,  a) ->
  52 >         k a   `thenUs` \(ls',bs',bls', b) ->
  53 >         returnUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
  54 >
  55 > returnLbl :: a -> Lbl a
  56 > returnLbl a = returnUs ([],[],[],a)
  57 >
  58 > mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b]
  59 > mapLbl f [] = returnLbl []
  60 > mapLbl f (x:xs)
  61 >       = f x           `thenLbl` \x ->
  62 >         mapLbl f xs   `thenLbl` \xs ->
  63 >         returnLbl (x:xs)
  64
  65 -----------------------------------------------------------------------------
  66
  67 This is terribly inefficient.
  68
  69 > mkLoops :: DefExpr -> UniqSM ([(Id,DefExpr)],DefExpr)
  70 > mkLoops e =
  71 >  error "mkLoops"
  72 >{- LATER:
  73 >       loop [] e `thenUs` \(ls,bs,bls,e) ->
  74
  75 Throw away all the extracted bindings that can't be reached.  These
  76 can occur as the result of some forward loops being short-circuited by
  77 back-loops.  We find out which bindings can be reached by a
  78 depth-first search of the call graph starting with the free variables
  79 of the expression being returned.
  80
  81 >       let
  82 >               loops_out = filter deforestable (freeVars e)
  83 >               (_,reachable) = dfs (==) r ([],[]) loops_out
  84 >               r f = lookup f bs
  85 >
  86 >               lookup f [] = []
  87 >               lookup f ((g,out,_):xs) | f == g = out
  88 >                                       | otherwise = lookup f xs
  89 >
  90 >               isReachable (f,_,_) = f `elem` reachable
  91 >       in
  92 >       returnUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
  93 >   where
  94
  95 >       loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
  96
  97 >       loop ls (Var (Label e e1))
  98 >           =
  99 >            d2c e `thenUs` \core_e ->
 100 >--          trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
 101
 102 >            mapUs (\(f,e',val_args,ty_args) ->
 103 >                    renameExprs e' e   `thenUs` \r ->
 104 >                    returnUs (f,val_args,ty_args,r)) ls `thenUs` \results ->
 105 >            let
 106 >               loops =
 107 >                       [ (f,val_args,ty_args,r) |
 108 >                         (f,val_args,ty_args,IsRenaming r) <- results ]
 109 >               inconsistent_renamings =
 110 >                       [ (f,r) |
 111 >                         (f,val_args,ty_args,InconsistentRenaming r)
 112 >                               <- results ]
 113 >            in
 114 >
 115 >            (case loops of
 116 >             [] ->
 117
 118 Ok, there are no loops (i.e. this expression hasn't occurred before).
 119 Prepare for a possible re-occurrence of *this* expression, by making
 120 up a new function name and type (laziness ensures that this isn't
 121 actually done unless the function is required).
 122
 123 The type of a new function, if one is generated at this point, is
 124 constructed as follows:
 125
 126     \/ a1 ... \/ an . b1 -> ... -> bn -> t
 127
 128 where a1...an are the free type variables in the expression, b1...bn
 129 are the types of the free variables in the expression, and t is the
 130 type of the expression itself.
 131
 132 >               let
 133 >
 134 >                  -- Collect the value/type arguments for the function
 135 >                  fvs       = freeVars e
 136 >                  val_args  = filter isArgId fvs
 137 >                  ty_args   = freeTyVars e
 138 >
 139 >                  -- Now to make up the type...
 140 >                  base_type = coreExprType core_e
 141 >                  fun_type  = glueTyArgs (map idType val_args) base_type
 142 >                  (_, type_of_f) = quantifyTy ty_args fun_type
 143 >               in
 144 >
 145 >               newDefId type_of_f      `thenUs` \f' ->
 146 >               let
 147 >                      f = replaceIdInfo f'
 148 >                               (addInfo (getIdInfo f') DoDeforest)
 149 >               in
 150 >               loop ((f,e,val_args,ty_args):ls) e1
 151 >                                       `thenUs` \res@(ls',bs,bls,e') ->
 152
 153 Key: ls = loops, bs = bindings, bls = back loops, e = expression.
 154
 155 If we are in a back-loop (i.e. we found a label somewhere below which
 156 this expression is a renaming of), then just insert the expression
 157 here.
 158
 159 Comment the next section out to disable back-loops.
 160
 161 (NB. I've seen this panic too - investigate?)
 162
 163 >               let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in
 164 >               if not (null back_loops){- && not (f `elem` ls')-} then
 165 >                  --if length back_loops > 1 then panic "barf!" else
 166 >                       d2c (head back_loops)   `thenUs` \core_e ->
 167 >                       pprTrace "Back Loop:\n" (ppr PprDebug core_e) $
 168
 169 If we find a back-loop that also occurs where we would normally make a
 170 new function...
 171
 172 >                  if f `elem` ls' then
 173 >                       d2c e'                  `thenUs` \core_e' ->
 174 >                       trace ("In Forward Loop " ++
 175 >                               ppShow 80 (ppr PprDebug f) ++ "\n" ++
 176 >                               ppShow 80 (ppr PprDebug core_e')) $
 177 >                       if f `notElem` (freeVars (head back_loops)) then
 178 >                               returnUs (ls', bs, bls, head back_loops)
 179 >                       else
 180 >                               panic "hello"
 181 >                  else
 182
 183 >                  returnUs (ls', bs, bls, head back_loops)
 184 >               else
 185
 186 If we are in a forward-loop (i.e. we found a label somewhere below
 187 which is a renaming of this one), then make a new function definition.
 188
 189 >               if f `elem` ls' then
 190 >
 191 >                       rebindExpr (mkLam ty_args val_args e')
 192 >                                                       `thenUs` \rhs ->
 193 >                       returnUs
 194 >                           (ls',
 195 >                            (f,filter deforestable (freeVars e'),e,rhs) : bs,
 196 >                            bls,
 197 >                            mkLoopFunApp val_args ty_args f)
 198
 199 otherwise, forget about it
 200
 201 >                       else returnUs res
 202
 203 This is a loop, just make a call to the function which we
 204 will create on the way back up the tree.
 205
 206 (NB: it appears that sometimes we do get more than one loop matching,
 207 investigate this?)
 208
 209 >             ((f,val_args,ty_args,r):_) ->
 210 >
 211 >                    returnUs
 212 >                       ([f],           -- found a loop, propagate it back
 213 >                        [],            -- no bindings
 214 >                        [],            -- no back loops
 215 >                        mkLoopFunApp (applyRenaming r val_args) ty_args f)
 216 >
 217 >               ) `thenUs` \res@(ls',bs,bls,e') ->
 218
 219 If this expression reoccurs, record the binding and replace the cycle
 220 with a call to the new function.  We also rebind all the free
 221 variables in the new function to avoid name clashes later.
 222
 223 >          let
 224 >               findBackLoops (g,r) bls
 225 >                       | consistent r' = subst s e' `thenUs` \e' ->
 226 >                                         returnUs ((g,e') : bls)
 227 >                       | otherwise     = returnUs bls
 228 >                       where
 229 >                         r' = map swap r
 230 >                         s = map (\(x,y) -> (x, Var (DefArgVar y))) (nub r')
 231 >          in
 232
 233 We just want the first one (ie. furthest up the tree), so reverse the
 234 list of inconsistent renamings.
 235
 236 >          foldrSUs findBackLoops [] (reverse inconsistent_renamings)
 237 >                                               `thenUs` \back_loops ->
 238
 239 Comment out the next block to disable back-loops.  ToDo: trace all of them.
 240
 241 >          if not (null back_loops) then
 242 >               d2c e'  `thenUs` \core_e ->
 243 >               trace ("Floating back loop:\n"
 244 >                       ++ ppShow 80 (ppr PprDebug core_e))
 245 >               returnUs (ls', bs, back_loops ++ bls, e')
 246 >          else
 247 >               returnUs res
 248
 249 >       loop ls e@(Var (DefArgVar v))
 250 >           = returnLbl e
 251 >       loop ls e@(Lit l)
 252 >           = returnLbl e
 253 >       loop ls (Con c ts es)
 254 >           = mapLbl (loopAtom ls) es       `thenLbl` \es ->
 255 >             returnLbl (Con c ts es)
 256 >       loop ls (Prim op ts es)
 257 >           = mapLbl (loopAtom ls) es       `thenLbl` \es ->
 258 >             returnLbl (Prim op ts es)
 259 >       loop ls (Lam vs e)
 260 >           = loop ls e                     `thenLbl` \e ->
 261 >             returnLbl (Lam vs e)
 262 >       loop ls (CoTyLam alpha e)
 263 >           = loop ls e                     `thenLbl` \e ->
 264 >             returnLbl (CoTyLam alpha e)
 265 >       loop ls (App e v)
 266 >           = loop ls e                     `thenLbl` \e ->
 267 >             loopAtom ls v                 `thenLbl` \v ->
 268 >             returnLbl (App e v)
 269 >       loop ls (CoTyApp e t)
 270 >           = loop ls e                     `thenLbl` \e ->
 271 >             returnLbl (CoTyApp e t)
 272 >       loop ls (Case e ps)
 273 >           = loop ls e                     `thenLbl` \e ->
 274 >             loopCaseAlts ls ps            `thenLbl` \ps ->
 275 >             returnLbl (Case e ps)
 276 >       loop ls (Let (NonRec v e) e')
 277 >           = loop ls e                     `thenLbl` \e ->
 278 >             loop ls e'                    `thenLbl` \e' ->
 279 >             returnLbl (Let (NonRec v e) e')
 280 >       loop ls (Let (Rec bs) e)
 281 >           = mapLbl loopRecBind bs         `thenLbl` \bs ->
 282 >             loop ls e                     `thenLbl` \e ->
 283 >             returnLbl (Let (Rec bs) e)
 284 >           where
 285 >             vs = map fst bs
 286 >             loopRecBind (v, e)
 287 >                   = loop ls e             `thenLbl` \e ->
 288 >                     returnLbl (v, e)
 289 >       loop ls e
 290 >           = defPanic "Cyclic" "loop" e
 291
 292 >       loopAtom ls (VarArg (DefArgExpr e))
 293 >             = loop ls e                     `thenLbl` \e ->
 294 >               returnLbl (VarArg (DefArgExpr e))
 295 >       loopAtom ls (VarArg e@(DefArgVar v))
 296 >             = defPanic "Cyclic" "loopAtom" (Var e)
 297 >       loopAtom ls (VarArg e@(Label _ _))
 298 >             = defPanic "Cyclic" "loopAtom" (Var e)
 299 >       loopAtom ls e@(LitArg l)
 300 >             = returnLbl e
 301 >
 302 >       loopCaseAlts ls (AlgAlts as def) =
 303 >               mapLbl loopAlgAlt as            `thenLbl` \as ->
 304 >               loopDefault ls def              `thenLbl` \def ->
 305 >               returnLbl (AlgAlts as def)
 306 >             where
 307 >               loopAlgAlt (c, vs, e) =
 308 >                       loop ls e               `thenLbl` \e ->
 309 >                       returnLbl (c, vs, e)
 310
 311 >       loopCaseAlts ls (PrimAlts as def) =
 312 >               mapLbl loopPrimAlt as           `thenLbl` \as ->
 313 >               loopDefault ls def              `thenLbl` \def ->
 314 >               returnLbl (PrimAlts as def)
 315 >             where
 316 >               loopPrimAlt (l, e) =
 317 >                       loop ls e               `thenLbl` \e ->
 318 >                       returnLbl (l, e)
 319
 320 >       loopDefault ls NoDefault =
 321 >               returnLbl NoDefault
 322 >       loopDefault ls (BindDefault v e) =
 323 >               loop ls e                       `thenLbl` \e ->
 324 >               returnLbl (BindDefault v e)
 325 > -}
 326
 327 > mkVar v = VarArg (DefArgExpr (Var (DefArgVar v)))
 328
 329 -----------------------------------------------------------------------------
 330 The next function is applied to all deforestable functions which are
 331 placed in the environment.  Given a list of free variables in the
 332 recursive set of which the function is a member, this funciton
 333 abstracts those variables, generates a new Id with the new type, and
 334 returns a substitution element which can be applied to all other
 335 expressions and function right hand sides that call this function.
 336
 337         (freeVars e) \subseteq (freeVars l)
 338
 339 > fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)])
 340 > fixupFreeVars total_fvs id e =
 341 >       case fvs of
 342 >               [] -> ((id,e),[])
 343 >               _  -> let new_type =
 344 >                               glueTyArgs (map idType fvs)
 345 >                                       (idType id)
 346 >                         new_id =
 347 >                               updateIdType id new_type
 348 >                     in
 349 >                     let
 350 >                         t = foldl App (Var (DefArgVar new_id))
 351 >                                               (map mkVar fvs)
 352 >                     in
 353 >                     trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
 354 >                     ((new_id, mkValLam fvs e), [(id,t)])
 355 >       where
 356 >               fvs = case e of
 357 >                       Lam bvs e -> filter (`notElem` bvs) total_fvs
 358 >                       _ -> total_fvs
 359
 360 > swap (x,y) = (y,x)
 361
 362 > applyRenaming :: [(Id,Id)] -> [Id] -> [Id]
 363 > applyRenaming r ids = map rename ids
 364 >    where
 365 >       rename x = case [ y | (x',y) <- r, x' `eqId` x ] of
 366 >                       [] -> panic "Cyclic(rename): no match in rename"
 367 >                       (y:_) -> y
 368
 369 > mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
 370 > mkLoopFunApp val_args ty_args f =
 371 >       foldl App
 372 >         (foldl CoTyApp (Var (DefArgVar f))
 373 >           (mkTyVarTys ty_args))
 374 >               (map mkVar val_args)
 375
 376 -----------------------------------------------------------------------------
 377 Removing duplicates from a list of definitions.
 378
 379 > removeDuplicateDefinitions
 380 >       :: [(DefExpr,(Id,DefExpr))]     -- (label,(id,rhs))
 381 >       -> UniqSM [(Id,DefExpr)]
 382
 383 > removeDuplicateDefinitions defs =
 384 >       foldrSUs rem ([],[]) defs       `thenUs` \(newdefs,s) ->
 385 >       mapUs (\(l,(f,e)) -> subst s e `thenUs` \e ->
 386 >                             returnUs (f, e)) newdefs
 387 >   where
 388
 389 >       rem d@(l,(f,e)) (defs,s) =
 390 >               findDup l defs          `thenUs` \maybe ->
 391 >               case maybe of
 392 >                  Nothing -> returnUs (d:defs,s)
 393 >                  Just g  -> returnUs (defs, (f,(Var.DefArgVar) g):s)
 394
 395 We insist that labels rename in both directions, is this necessary?
 396
 397 >       findDup l [] = returnUs Nothing
 398 >       findDup l ((l',(f,e)):defs) =
 399 >               renameExprs l l'        `thenUs` \r ->
 400 >               case r of
 401 >                 IsRenaming _ -> renameExprs l' l      `thenUs` \r ->
 402 >                                 case r of
 403 >                                       IsRenaming r -> returnUs (Just f)
 404 >                                       _ -> findDup l defs
 405 >                 _ -> findDup l defs