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