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