Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/opt/fixfix.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/opt/fixfix.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 620, Wed Apr 19 20:27:38 2000 UTC revision 621, Wed Apr 19 22:44:30 2000 UTC
# Line 98  Line 98 
98      fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)      fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
99        | fdcon (fv,_) = fv        | fdcon (fv,_) = fv
100    
101      (* recognize the curried essence of a function.      (* Recognize the curried essence of a function.
102       * - hd:fkind option identifies the head of the curried function       * - hd:fkind option identifies the head of the curried function
103       * - na:int gives the number of args still allowed *)       * - na:int gives the number of args still allowed *)
104      fun curry (hd,na)      fun curry (hd,na)
# Line 106  Line 106 
106                              F.RET[F.VAR lv]))) =                              F.RET[F.VAR lv]))) =
107          if lv = f andalso na >= length args then          if lv = f andalso na >= length args then
108              case (hd,fk)              case (hd,fk)
              of ((* (SOME{isrec=NONE,...},{isrec=SOME _,...}) | *)  
                  (SOME{cconv=F.CC_FCT,...},{cconv=F.CC_FUN _,...}) |  
                  (SOME{cconv=F.CC_FUN _,...},{cconv=F.CC_FCT,...})) =>  
                 ([], le)  
               (* | ((NONE,_) |  
                     (SOME{isrec=SOME _,...},_) |  
                     (SOME{isrec=NONE,...},{isrec=NONE,...})) => *)  
109                (* recursive functions are only accepted for uncurrying                (* recursive functions are only accepted for uncurrying
110                 * if they are the head of the function or if the head                 * if they are the head of the function or if the head
111                 * is already recursive *)                 * is already recursive *)
112                 of ((SOME{isrec=NONE,...},{isrec=SOME _,...}) |
113                     (SOME{cconv=F.CC_FCT,...},{cconv=F.CC_FUN (LK.FF_VAR _),...}) |
114                     (SOME{cconv=F.CC_FUN _,...},{cconv=F.CC_FCT,...})) =>
115                    ([], le)
116                | _ =>                | _ =>
117                  let val (funs,body) = curry (SOME fk, na - (length args)) body                  let val (funs,body) =
118                            curry (case hd of NONE => SOME fk | _ => hd,
119                                   na - (length args)) body
120                  in ((fk,f,args)::funs,body)                  in ((fk,f,args)::funs,body)
121                  end                  end
122          else          else
# Line 138  Line 137 
137                               | _ => bug "strange isrec") rtys                               | _ => bug "strange isrec") rtys
138    
139              (* create the new fkinds *)              (* create the new fkinds *)
140              val ncconv = case #cconv(#1(List.last args)) of              val ncconv =
141                  F.CC_FUN(LK.FF_VAR(_,raw)) => F.CC_FUN(LK.FF_VAR(true, raw))                  case #cconv(#1(hd args))
142                     of F.CC_FCT => F.CC_FCT
143                      | _ => case #cconv(#1(List.last args))
144                              of F.CC_FUN(LK.FF_VAR(_,raw)) =>
145                                 F.CC_FUN(LK.FF_VAR(true, raw))
146                | cconv => cconv                | cconv => cconv
147              val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)              val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)
148              val nfk' = {inline= #inline nfk', isrec= #isrec nfk',              val nfk' = {inline= #inline nfk', isrec= #isrec nfk',
# Line 202  Line 205 
205         in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))         in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))
206         end         end
207       | F.FIX (fdecs,le) =>       | F.FIX (fdecs,le) =>
208         let val funs = S.addList(S.empty, map #2 fdecs) (* set of funs defined by the FIX *)         let (* set of funs defined by the FIX *)
209               val funs = S.addList(S.empty, map #2 fdecs)
210    
211             (* create call-counters for each fun and add them to fm *)             (* create call-counters for each fun and add them to fm *)
212             val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>             val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>
# Line 223  Line 227 
227                             uncurry(args,body)                             uncurry(args,body)
228                         (* add the wrapper function *)                         (* add the wrapper function *)
229                         val cs = map (fn _ => ref(0,0)) fargs                         val cs = map (fn _ => ref(0,0)) fargs
230                         val nm = M.insert(m, f, ([f'], 1, fk, fargs, fbody, cf, cs))                         val nm = M.insert(m, f,
231                                             ([f'], 1, fk, fargs, fbody, cf, cs))
232                     (* now, retry ffun with the uncurried function *)                     (* now, retry ffun with the uncurried function *)
233                     in ffun((fk', f', fargs', fbody', ref 1),                     in ffun((fk', f', fargs', fbody', ref 1),
234                             (s+1, fv, S.add(funs, f'), nm))                             (s+1, fv, S.add(funs, f'), nm))
# Line 236  Line 241 
241                         val (mf,cs) = foldr (fn ((v,t),(m,cs)) =>                         val (mf,cs) = foldr (fn ((v,t),(m,cs)) =>
242                                              let val c = ref(0, 0)                                              let val c = ref(0, 0)
243                                              in (M.insert(m, v, Arg(newdepth, c)),                                              in (M.insert(m, v, Arg(newdepth, c)),
244                                                  c::cs) end)                                                  c::cs)
245                                                end)
246                                             (mf,[]) args                                             (mf,[]) args
247                         val (fs,ffv,body) = fexp mf newdepth body                         val (fs,ffv,body) = fexp mf newdepth body
248                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)
249                         val ifv = S.intersection(ffv, funs) (* set of rec funs ref'ed *)                         (* set of rec funs ref'ed *)
250                           val ifv = S.intersection(ffv, funs)
251                     in                     in
252                         (fs + s, S.union(ffv, fv), funs,                         (fs + s, S.union(ffv, fv), funs,
253                          M.insert(m,f,(S.listItems ifv, fs, fk, args, body, cf, cs)))                          M.insert(m, f,
254                                     (S.listItems ifv, fs, fk, args, body, cf, cs)))
255                     end                     end
256    
257             (* process the main lexp and make it into a dummy function.             (* process the main lexp and make it into a dummy function.
# Line 353  Line 361 
361                 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end                 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end
362             val narms = length arms             val narms = length arms
363             val (s,smax,fv,arms) =             val (s,smax,fv,arms) =
364                 foldl (fn ((s1,fv1,arm),(s2,smax,fv2,arms)) =>                 foldr (fn ((s1,fv1,arm),(s2,smax,fv2,arms)) =>
365                        (s1+s2, Int.max(s1,smax), S.union(fv1, fv2), arm::arms))                        (s1+s2, Int.max(s1,smax), S.union(fv1, fv2), arm::arms))
366                       (narms, 0, S.empty, []) (map farm arms)                       (narms, 0, S.empty, []) (map farm arms)
367         in (case lookup v         in (case lookup v

Legend:
Removed from v.620  
changed lines
  Added in v.621

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0