home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / codegen / opt.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.0 KB  |  92 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. signature OPT =
  3. sig
  4.   val freevars : Lambda.lexp -> Access.lvar list
  5.   val closestr : (Access.lvar -> string) * (Access.lvar -> Lambda.lty)
  6.                   * Lambda.lexp * Access.lvar list -> Lambda.lexp
  7.                   
  8.   val closetop : Lambda.lexp * Access.lvar list 
  9.                   * (Access.lvar -> Lambda.lty) -> Lambda.lexp
  10. end
  11.  
  12. structure Opt : OPT =
  13. struct
  14.  
  15. open Access Types Variables Lambda
  16.  
  17. fun root [v] = v | root (_::p) = root p
  18.   | root _ = ErrorMsg.impossible "root [] in codegen/opt";
  19.  
  20. fun freevars e =
  21.     let val t = Intset.new()
  22.     val set = Intset.add t
  23.     val unset = Intset.rmv t
  24.     val done = Intset.mem t
  25.     val free : int list ref = ref []
  26.     val rec mak =
  27.      fn VAR w => if done w then () else (set w; free := w :: !free)
  28.       | FN (w,_,b) => (set w; mak b; unset w)
  29.       | FIX (vl,_,el,b) => (app set vl; app mak (b::el); app unset vl)
  30.       | APP (f,a) => (mak f; mak a)
  31.       | SWITCH(e,_,l,d) => 
  32.           (mak e;
  33.            app (fn (DATAcon(_,VARIABLE(PATH p),_),e) =>
  34.              (mak(VAR(root p)); mak e)
  35.              | (DATAcon(_,VARIABLEc(PATH p),_),e) =>
  36.              (mak(VAR(root p)); mak e)
  37.              | (c,e) => mak e)
  38.            l;
  39.            case d of NONE => () | SOME a => mak a)
  40.       | RECORD l => app mak l
  41.           | VECTOR l => app mak l
  42.           | CON((_,VARIABLE(PATH p),_),e) => (mak(VAR(root p)); mak e)
  43.           | CON((_,VARIABLEc(PATH p),_),e) => (mak(VAR(root p)); mak e)
  44.           | CON(_,e) => mak e
  45.           | DECON(_,e) => mak e
  46.       | SELECT (i,e) => mak e
  47.       | HANDLE (a,h) => (mak a; mak h)
  48.       | RAISE(e,_) => mak e
  49.       | INT _ => ()
  50.       | REAL _ => ()
  51.       | STRING _ => ()
  52.       | PRIM _ => ()
  53.           | WRAP(_,e) => mak e
  54.           | UNWRAP(_,e) => mak e
  55.     in  mak e; !free
  56.     end
  57.  
  58. val boot_zeroSym = Symbol.varSymbol "boot_zero" (* receives unit *)
  59. val boot_oneSym = Symbol.varSymbol "boot_one"   (* traverses free list *)
  60. val boot_twoSym = Symbol.varSymbol "boot_two"   (* final bogus arg *)
  61.  
  62. fun closestr(lookup: int->string, getty : int -> lty, 
  63.              e:lexp, extras : int list) : lexp =
  64.     let val fv = SortedList.uniq(extras @ freevars e)
  65.     val names = map lookup fv
  66.         fun g(v,(f,t)) = 
  67.            let val w = namedLvar boot_oneSym
  68.                val t' = RECORDty[getty v,t]
  69.         in (FN(w,t',APP(FN(v,BOGUSty,APP(f,SELECT(1,(VAR w)))),
  70.                  SELECT(0,(VAR w)))),
  71.                 t')
  72.        end
  73.         val (body,t) = fold g fv (FN(namedLvar boot_twoSym,BOGUSty,e),BOGUSty)
  74.         val sl = fold (fn (s,f) => RECORD[STRING s, f]) names (RECORD[])
  75.         val _ = if !System.Control.debugging
  76.             then app (fn s => app System.Print.say[s," "]) names
  77.             else ()
  78.      in FN(namedLvar boot_zeroSym,INTty,RECORD[body,sl])
  79.     end
  80.  
  81. val lookupSym = Symbol.varSymbol "lookup"
  82.  
  83. fun closetop(le: lexp, extras: int list, getty : lvar -> lty): lexp =
  84.   let val fv = SortedList.uniq(extras @ freevars le)
  85.       val looker = namedLvar lookupSym
  86.       fun g(v,f) = APP(FN(v,BOGUSty,f),
  87.                        UNWRAP(getty(v),APP(VAR looker,INT v)))
  88.    in FN(looker,ARROWty(INTty,BOXEDty),fold g fv le)
  89.   end
  90.  
  91. end (* structure Opt *)
  92.