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, mkTyVarTy,
  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 >                       trace ("Back Loop:\n" ++
 169 >                               ppShow 80 (ppr PprDebug core_e)) $
 170
 171 If we find a back-loop that also occurs where we would normally make a
 172 new function...
 173
 174 >                  if f `elem` ls' then
 175 >                       d2c e'                  `thenUs` \core_e' ->
 176 >                       trace ("In Forward Loop " ++
 177 >                               ppShow 80 (ppr PprDebug f) ++ "\n" ++
 178 >                               ppShow 80 (ppr PprDebug core_e')) $
 179 >                       if f `notElem` (freeVars (head back_loops)) then
 180 >                               returnUs (ls', bs, bls, head back_loops)
 181 >                       else
 182 >                               panic "hello"
 183 >                  else
 184
 185 >                  returnUs (ls', bs, bls, head back_loops)
 186 >               else
 187
 188 If we are in a forward-loop (i.e. we found a label somewhere below
 189 which is a renaming of this one), then make a new function definition.
 190
 191 >               if f `elem` ls' then
 192 >
 193 >                       rebindExpr (mkLam ty_args val_args e')
 194 >                                                       `thenUs` \rhs ->
 195 >                       returnUs
 196 >                           (ls',
 197 >                            (f,filter deforestable (freeVars e'),e,rhs) : bs,
 198 >                            bls,
 199 >                            mkLoopFunApp val_args ty_args f)
 200
 201 otherwise, forget about it
 202
 203 >                       else returnUs res
 204
 205 This is a loop, just make a call to the function which we
 206 will create on the way back up the tree.
 207
 208 (NB: it appears that sometimes we do get more than one loop matching,
 209 investigate this?)
 210
 211 >             ((f,val_args,ty_args,r):_) ->
 212 >
 213 >                    returnUs
 214 >                       ([f],           -- found a loop, propagate it back
 215 >                        [],            -- no bindings
 216 >                        [],            -- no back loops
 217 >                        mkLoopFunApp (applyRenaming r val_args) ty_args f)
 218 >
 219 >               ) `thenUs` \res@(ls',bs,bls,e') ->
 220
 221 If this expression reoccurs, record the binding and replace the cycle
 222 with a call to the new function.  We also rebind all the free
 223 variables in the new function to avoid name clashes later.
 224
 225 >          let
 226 >               findBackLoops (g,r) bls
 227 >                       | consistent r' = subst s e' `thenUs` \e' ->
 228 >                                         returnUs ((g,e') : bls)
 229 >                       | otherwise     = returnUs bls
 230 >                       where
 231 >                         r' = map swap r
 232 >                         s = map (\(x,y) -> (x, Var (DefArgVar y))) (nub r')
 233 >          in
 234
 235 We just want the first one (ie. furthest up the tree), so reverse the
 236 list of inconsistent renamings.
 237
 238 >          foldrSUs findBackLoops [] (reverse inconsistent_renamings)
 239 >                                               `thenUs` \back_loops ->
 240
 241 Comment out the next block to disable back-loops.  ToDo: trace all of them.
 242
 243 >          if not (null back_loops) then
 244 >               d2c e'  `thenUs` \core_e ->
 245 >               trace ("Floating back loop:\n"
 246 >                       ++ ppShow 80 (ppr PprDebug core_e))
 247 >               returnUs (ls', bs, back_loops ++ bls, e')
 248 >          else
 249 >               returnUs res
 250
 251 >       loop ls e@(Var (DefArgVar v))
 252 >           = returnLbl e
 253 >       loop ls e@(Lit l)
 254 >           = returnLbl e
 255 >       loop ls (Con c ts es)
 256 >           = mapLbl (loopAtom ls) es       `thenLbl` \es ->
 257 >             returnLbl (Con c ts es)
 258 >       loop ls (Prim op ts es)
 259 >           = mapLbl (loopAtom ls) es       `thenLbl` \es ->
 260 >             returnLbl (Prim op ts es)
 261 >       loop ls (Lam vs e)
 262 >           = loop ls e                     `thenLbl` \e ->
 263 >             returnLbl (Lam vs e)
 264 >       loop ls (CoTyLam alpha e)
 265 >           = loop ls e                     `thenLbl` \e ->
 266 >             returnLbl (CoTyLam alpha e)
 267 >       loop ls (App e v)
 268 >           = loop ls e                     `thenLbl` \e ->
 269 >             loopAtom ls v                 `thenLbl` \v ->
 270 >             returnLbl (App e v)
 271 >       loop ls (CoTyApp e t)
 272 >           = loop ls e                     `thenLbl` \e ->
 273 >             returnLbl (CoTyApp e t)
 274 >       loop ls (Case e ps)
 275 >           = loop ls e                     `thenLbl` \e ->
 276 >             loopCaseAlts ls ps            `thenLbl` \ps ->
 277 >             returnLbl (Case e ps)
 278 >       loop ls (Let (NonRec v e) e')
 279 >           = loop ls e                     `thenLbl` \e ->
 280 >             loop ls e'                    `thenLbl` \e' ->
 281 >             returnLbl (Let (NonRec v e) e')
 282 >       loop ls (Let (Rec bs) e)
 283 >           = mapLbl loopRecBind bs         `thenLbl` \bs ->
 284 >             loop ls e                     `thenLbl` \e ->
 285 >             returnLbl (Let (Rec bs) e)
 286 >           where
 287 >             vs = map fst bs
 288 >             loopRecBind (v, e)
 289 >                   = loop ls e             `thenLbl` \e ->
 290 >                     returnLbl (v, e)
 291 >       loop ls e
 292 >           = defPanic "Cyclic" "loop" e
 293
 294 >       loopAtom ls (VarArg (DefArgExpr e))
 295 >             = loop ls e                     `thenLbl` \e ->
 296 >               returnLbl (VarArg (DefArgExpr e))
 297 >       loopAtom ls (VarArg e@(DefArgVar v))
 298 >             = defPanic "Cyclic" "loopAtom" (Var e)
 299 >       loopAtom ls (VarArg e@(Label _ _))
 300 >             = defPanic "Cyclic" "loopAtom" (Var e)
 301 >       loopAtom ls e@(LitArg l)
 302 >             = returnLbl e
 303 >
 304 >       loopCaseAlts ls (AlgAlts as def) =
 305 >               mapLbl loopAlgAlt as            `thenLbl` \as ->
 306 >               loopDefault ls def              `thenLbl` \def ->
 307 >               returnLbl (AlgAlts as def)
 308 >             where
 309 >               loopAlgAlt (c, vs, e) =
 310 >                       loop ls e               `thenLbl` \e ->
 311 >                       returnLbl (c, vs, e)
 312
 313 >       loopCaseAlts ls (PrimAlts as def) =
 314 >               mapLbl loopPrimAlt as           `thenLbl` \as ->
 315 >               loopDefault ls def              `thenLbl` \def ->
 316 >               returnLbl (PrimAlts as def)
 317 >             where
 318 >               loopPrimAlt (l, e) =
 319 >                       loop ls e               `thenLbl` \e ->
 320 >                       returnLbl (l, e)
 321
 322 >       loopDefault ls NoDefault =
 323 >               returnLbl NoDefault
 324 >       loopDefault ls (BindDefault v e) =
 325 >               loop ls e                       `thenLbl` \e ->
 326 >               returnLbl (BindDefault v e)
 327 > -}
 328
 329 > mkVar v = VarArg (DefArgExpr (Var (DefArgVar v)))
 330
 331 -----------------------------------------------------------------------------
 332 The next function is applied to all deforestable functions which are
 333 placed in the environment.  Given a list of free variables in the
 334 recursive set of which the function is a member, this funciton
 335 abstracts those variables, generates a new Id with the new type, and
 336 returns a substitution element which can be applied to all other
 337 expressions and function right hand sides that call this function.
 338
 339         (freeVars e) \subseteq (freeVars l)
 340
 341 > fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)])
 342 > fixupFreeVars total_fvs id e =
 343 >       case fvs of
 344 >               [] -> ((id,e),[])
 345 >               _  -> let new_type =
 346 >                               glueTyArgs (map idType fvs)
 347 >                                       (idType id)
 348 >                         new_id =
 349 >                               updateIdType id new_type
 350 >                     in
 351 >                     let
 352 >                         t = foldl App (Var (DefArgVar new_id))
 353 >                                               (map mkVar fvs)
 354 >                     in
 355 >                     trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
 356 >                     ((new_id, mkValLam fvs e), [(id,t)])
 357 >       where
 358 >               fvs = case e of
 359 >                       Lam bvs e -> filter (`notElem` bvs) total_fvs
 360 >                       _ -> total_fvs
 361
 362 > swap (x,y) = (y,x)
 363
 364 > applyRenaming :: [(Id,Id)] -> [Id] -> [Id]
 365 > applyRenaming r ids = map rename ids
 366 >    where
 367 >       rename x = case [ y | (x',y) <- r, x' `eqId` x ] of
 368 >                       [] -> panic "Cyclic(rename): no match in rename"
 369 >                       (y:_) -> y
 370
 371 > mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
 372 > mkLoopFunApp val_args ty_args f =
 373 >       foldl App
 374 >         (foldl CoTyApp (Var (DefArgVar f))
 375 >           (map mkTyVarTy ty_args))
 376 >               (map mkVar val_args)
 377
 378 -----------------------------------------------------------------------------
 379 Removing duplicates from a list of definitions.
 380
 381 > removeDuplicateDefinitions
 382 >       :: [(DefExpr,(Id,DefExpr))]     -- (label,(id,rhs))
 383 >       -> UniqSM [(Id,DefExpr)]
 384
 385 > removeDuplicateDefinitions defs =
 386 >       foldrSUs rem ([],[]) defs       `thenUs` \(newdefs,s) ->
 387 >       mapUs (\(l,(f,e)) -> subst s e `thenUs` \e ->
 388 >                             returnUs (f, e)) newdefs
 389 >   where
 390
 391 >       rem d@(l,(f,e)) (defs,s) =
 392 >               findDup l defs          `thenUs` \maybe ->
 393 >               case maybe of
 394 >                  Nothing -> returnUs (d:defs,s)
 395 >                  Just g  -> returnUs (defs, (f,(Var.DefArgVar) g):s)
 396
 397 We insist that labels rename in both directions, is this necessary?
 398
 399 >       findDup l [] = returnUs Nothing
 400 >       findDup l ((l',(f,e)):defs) =
 401 >               renameExprs l l'        `thenUs` \r ->
 402 >               case r of
 403 >                 IsRenaming _ -> renameExprs l' l      `thenUs` \r ->
 404 >                                 case r of
 405 >                                       IsRenaming r -> returnUs (Just f)
 406 >                                       _ -> findDup l defs
 407 >                 _ -> findDup l defs