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 219, Tue Mar 9 01:07:30 1999 UTC revision 220, Tue Mar 9 02:15:05 1999 UTC
# Line 29  Line 29 
29      structure M = IntmapF      structure M = IntmapF
30      structure PP = PPFlint      structure PP = PPFlint
31      structure LT = LtyExtern      structure LT = LtyExtern
32        structure LK = LtyKernel
33      structure OU = OptUtils      structure OU = OptUtils
34      structure CTRL = Control.FLINT      structure CTRL = FLINT_Control
35  in  in
36    
37  val say = Control.Print.say  val say = Control_Print.say
38  fun bug msg = ErrorMsg.impossible ("FixFix: "^msg)  fun bug msg = ErrorMsg.impossible ("FixFix: "^msg)
39  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)  fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
40  fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)  fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
# Line 95  Line 96 
96        | fdcon (fv,_) = fv        | fdcon (fv,_) = fv
97    
98      (* recognize the curried essence of a function.      (* recognize the curried essence of a function.
99       * - hd:bool identifies the head of the (potentially) curried function       * - hd:fkind option identifies the head of the curried function
      * - r:bool indicates whether the head was recursive  
100       * - na:int gives the number of args still allowed *)       * - na:int gives the number of args still allowed *)
101      fun curry (hd,r,na) (le as (F.FIX([(fk,f,args,body)], F.RET[F.VAR lv]))) =      fun curry (hd,na)
102          if lv = f andalso #inline fk = F.IH_SAFE then                (le as (F.FIX([(fk as {inline=F.IH_SAFE,...},f,args,body)],
103              let val fisrec = isSome(#isrec fk)                              F.RET[F.VAR lv]))) =
104                  val na = na - length args          if lv = f andalso na >= length args then
105              in if na >= 0 andalso (hd orelse r orelse not fisrec) then              case (hd,fk)
106                 of ((* (SOME{isrec=NONE,...},{isrec=SOME _,...}) | *)
107                     (SOME{cconv=F.CC_FCT,...},{cconv=F.CC_FUN _,...}) |
108                     (SOME{cconv=F.CC_FUN _,...},{cconv=F.CC_FCT,...})) =>
109                    ([], le)
110                  (* | ((NONE,_) |
111                        (SOME{isrec=SOME _,...},_) |
112                        (SOME{isrec=NONE,...},{isrec=NONE,...})) => *)
113                  (* recursive functions are only accepted for uncurrying                  (* recursive functions are only accepted for uncurrying
114                   * if they are the head of the function or if the head                   * if they are the head of the function or if the head
115                   * is already recursive *)                   * is already recursive *)
116                  let val (funs,body) =                | _ =>
117                          curry (false, r orelse fisrec, na) body                  let val (funs,body) = curry (SOME fk, na - (length args)) body
118                  in ((fk,f,args)::funs,body)                  in ((fk,f,args)::funs,body)
119                  end                  end
                else ([], le)  
             end  
120          else          else
121              (* this "never" occurs, but dead-code removal is not bullet-proof *)              (* this "never" occurs, but dead-code removal is not bullet-proof *)
122              ([], le)              ([], le)
123        | curry first le = ([], le)        | curry _ le = ([], le)
124    
125        exception Uncurryable
126    
127      (* do the actual uncurrying *)      (* do the actual uncurrying *)
128      fun uncurry (args as (fk,f,fargs)::_::_,body) =      fun uncurry (args as (fk,f,fargs)::_::_,body) =
# Line 128  Line 135 
135                               | _ => bug "strange isrec") rtys                               | _ => bug "strange isrec") rtys
136    
137              (* create the new fkinds *)              (* create the new fkinds *)
138                val ncconv = case #cconv(#1(List.last args)) of
139                    F.CC_FUN(LK.FF_VAR(_,raw)) => F.CC_FUN(LK.FF_VAR(true, raw))
140                  | cconv => cconv
141              val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)              val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)
142                val nfk' = {inline= #inline nfk', isrec= #isrec nfk',
143                            known= #known nfk', cconv= ncconv}
144    
145              (* funarg renaming *)              (* funarg renaming *)
146              fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs              fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs
# Line 201  Line 213 
213             (* process each fun *)             (* process each fun *)
214             fun ffun (fdec as (fk as {isrec,...}:F.fkind,f,args,body,cf),             fun ffun (fdec as (fk as {isrec,...}:F.fkind,f,args,body,cf),
215                       (s,fv,funs,m)) =                       (s,fv,funs,m)) =
216                 case curry (true,false,!maxargs)                 case curry (NONE,!maxargs)
217                            (F.FIX([(fk,f,args,body)], F.RET[F.VAR f]))                            (F.FIX([(fk,f,args,body)], F.RET[F.VAR f]))
218                  of (args as _::_::_,body) => (* curried function *)                  of (args as _::_::_,body) => (* curried function *)
219                     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =                     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =
# Line 310  Line 322 
322         in         in
323             (scall + (length args), addvs(S.singleton f, args), lexp)             (scall + (length args), addvs(S.singleton f, args), lexp)
324         end         end
325       | F.TFN ((f,args,body),le) =>       | F.TFN ((tfk,f,args,body),le) =>
326         let val (se,fve,le) = loop le         let val (se,fve,le) = loop le
327             val (sb,fvb,body) = loop body             val (sb,fvb,body) = loop body
328         in (sb + se, S.union(S.rmv(f, fve), fvb), F.TFN((f, args, body), le))         in (sb + se, S.union(S.rmv(f, fve), fvb),
329               F.TFN((tfk, f, args, body), le))
330         end         end
331       | F.TAPP (F.VAR f,args) =>       | F.TAPP (F.VAR f,args) =>
332         (* The cost of TAPP is kinda hard to estimate.  It can be very cheap,         (* The cost of TAPP is kinda hard to estimate.  It can be very cheap,

Legend:
Removed from v.219  
changed lines
  Added in v.220

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