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