1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 \section[Cyclic]{Knot tying}
6 >#include "HsVersions.h"
7 >
8 > module Cyclic (
9 >       mkLoops, fixupFreeVars
10 >       ) where
12 > import DefSyn
13 > import PlainCore
14 > import DefUtils
15 > import Def2Core       ( d2c, defPanic )
16 >#ifdef __HBC__
17 > import Trace
18 >#endif
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
34 -----------------------------------------------------------------------------
35 A more efficient representation for lists that are extended multiple
36 times, but only examined once.
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
45 -----------------------------------------------------------------------------
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)
70 -----------------------------------------------------------------------------
72 This is terribly inefficient.
74 > mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr)
75 > mkLoops e =
76 >  error "mkLoops"
77 >{- LATER:
78 >       loop [] e thenSUs \(ls,bs,bls,e) ->
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.
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
100 >       loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
102 >       loop ls (CoVar (Label e e1))
103 >           =
104 >            d2c e thenSUs \core_e ->
105 >--          trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $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 > [] -> 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). 128 The type of a new function, if one is generated at this point, is 129 constructed as follows: 131 \/ a1 ... \/ an . b1 -> ... -> bn -> t 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. 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') -> 158 Key: ls = loops, bs = bindings, bls = back loops, e = expression. 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. 164 Comment the next section out to disable back-loops. 166 (NB. I've seen this panic too - investigate?) 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))$
175 If we find a back-loop that also occurs where we would normally make a
176 new function...
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 189 > returnSUs (ls', bs, bls, head back_loops) 190 > else 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. 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) 205 otherwise, forget about it 207 > else returnSUs res 209 This is a loop, just make a call to the function which we 210 will create on the way back up the tree. 212 (NB: it appears that sometimes we do get more than one loop matching, 213 investigate this?) 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') -> 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. 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 239 We just want the first one (ie. furthest up the tree), so reverse the 240 list of inconsistent renamings. 242 > foldrSUs findBackLoops [] (reverse inconsistent_renamings) 243 > thenSUs \back_loops -> 245 Comment out the next block to disable back-loops. ToDo: trace all of them. 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 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 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) 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) 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 > -} 333 > mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v))) 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. 343 (freeVars e) \subseteq (freeVars l) 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
366 > swap (x,y) = (y,x)
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
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)
382 -----------------------------------------------------------------------------
383 Removing duplicates from a list of definitions.
385 > removeDuplicateDefinitions
386 >       :: [(DefExpr,(Id,DefExpr))]     -- (label,(id,rhs))
387 >       -> SUniqSM [(Id,DefExpr)]
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
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)
401 We insist that labels rename in both directions, is this necessary?
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