home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / codegen / reopen.sml < prev   
Encoding:
Text File  |  1993-01-27  |  5.3 KB  |  152 lines
  1. functor Reopen(structure Machm : CODEGENERATOR)
  2.         : sig val instrument: Lambda.lexp -> Lambda.lexp end =
  3. struct
  4. open  Basics Access Lambda
  5. structure U = System.Unsafe
  6. type object= U.object
  7. val cast = U.cast
  8.  
  9. structure DA = Dynamic(struct open Array
  10.                   type array=lexp Array.array
  11.                   type elem = lexp
  12.             end)
  13.  
  14. val saved = DA.array(RECORD [])
  15. val magiccount = ref 0
  16.  
  17. exception BadReal of string
  18.  
  19. fun codegen lambda =
  20.     let val _ = (MCprint.printLexp lambda; print "\n")
  21.         fun complain _ s = raise BadReal s
  22.         val code = Machm.generate(lambda,complain)
  23.      in U.CInterface.flush_cache code;
  24.             (U.boot : string -> (int->object) -> object) code
  25.     end
  26.  
  27. fun translatepath [v] = VAR v
  28.   | translatepath (x::p) = SELECT(x,translatepath p)
  29.  
  30. fun gettag obj = U.int (U.tuple obj sub 1)
  31.  
  32. exception Switch
  33. exception Env
  34.      
  35. fun switch(obj,cl,default) =
  36.     let fun try ((INTcon i, e)::r) = if (U.int obj = i handle U.Boxity=>false)
  37.                     then e else try r
  38.       | try ((REALcon _, e)::r) = raise Env
  39.       | try ((STRINGcon s, e)::r) = if (U.string obj = s
  40.                          handle U.Boxity=>false)
  41.                     then e else try r
  42.       | try((DATAcon(_,rep,_),e)::r) =
  43.         (case rep
  44.            of TAGGED i => if (gettag obj = i handle U.Boxity => false)
  45.                   then e else try r
  46.         | CONSTANT i => if (U.int obj = i handle U.Boxity => false)
  47.                 then e else try r
  48.         | TRANSPARENT =>
  49.                 if ((U.tuple obj; true) handle U.Boxity => false)
  50.                 then e else (try r handle Switch => e)
  51.         | TRANSB => if ((U.tuple obj; true) handle U.Boxity => false)
  52.                 then e else try r
  53.         | TRANSU => if ((U.int obj; true) handle U.Boxity => false)
  54.                 then e else try r
  55.         | REF => e
  56.         | _ => ErrorMsg.impossible "reopen.switch: funny datacon")
  57.       | try nil = case default
  58.             of SOME e => e
  59.              | NONE => raise Switch
  60.     in  try cl
  61.     handle Switch => 
  62.       ErrorMsg.impossible "reopen.switch: none of the datacons matched"
  63.     end
  64.  
  65. (***> here BOGUSty should be replaced by accurate type in the future <***)
  66. fun delayAnalyze lexp =
  67.  let val fv = Opt.freevars lexp
  68.      val env = mkLvar()
  69.      fun bind(i,nil) = lexp
  70.        | bind(i,a::r) = APP(FN(a,BOGUSty,bind(i+1,r)), SELECT(i, VAR env))
  71.      val magic = !magiccount
  72.   in magiccount := magic+1;
  73.      DA.update(saved,magic,FN(env,BOGUSty,bind(1,fv)));
  74.      print "magic = "; print magic; print "\n";
  75.      MCprint.printLexp(DA.sub(saved,magic)); print "\n";
  76.      (*APP(PRIM(P.delay,BOGUSty), 
  77.      RECORD([INT(System.Tags.tag_suspension div 2),
  78.             RECORD(INT magic :: map VAR fv)]))*)
  79.      RECORD(INT magic :: map VAR fv)
  80.  end
  81.  
  82. fun forcer (closure) =
  83.  let val m : object Intmap.intmap = Intmap.new(32,Env)
  84.      fun enter obj = let val v = mkLvar() in Intmap.add m (v,obj); VAR v end
  85.      val get = Intmap.map m
  86.      fun undelay (a: object array) =
  87.     let val e = 
  88.                APP(Opt.alphaConvert(DA.sub(saved,((cast (a sub 0)):int))), 
  89.                 enter(cast a))
  90.          in print "undelay:\n"; MCprint.printLexp e; print "\n"; e
  91.         end
  92.      fun eval lexp =
  93.         SOME(case lexp
  94.               of SELECT(i,VAR v) => 
  95.                      enter(cast(get v) sub i) before print "*1"
  96.                | SWITCH(VAR v,cel,default) => 
  97.                      switch(get v, cel,default) before print "*2"
  98.                | APP(PRIM(P.force,_), APP(PRIM(P.delay,_),b)) => 
  99.                      b before print "*3"
  100.            | APP(PRIM(P.force,_), VAR v) => 
  101.                      undelay(cast(get v)) before print "*4"
  102.            | VAR v => let val v' = get v
  103.                in if System.Unsafe.boxed v' then raise Env
  104.                 else INT(cast v') before print "*5"
  105.               end
  106.            | APP(PRIM(P.alength,_),VAR v) => 
  107.                      INT(Array.length(cast(get v))) before print "*6"
  108.            | APP(PRIM(P.slength,_),VAR v) => 
  109.                      INT(String.size(cast(get v))) before print "*7"
  110.            | APP(PRIM(P.ordof,_),RECORD([VAR v,VAR w])) => 
  111.             INT(String.ordof(cast(get v),cast(get w))
  112.                  handle Ord => raise Env)
  113.                         before print "*8"
  114.            | _ => raise Env)
  115.          handle Env => NONE
  116.      val reduce = Opt.greduce eval
  117.      fun looker i = get i handle Env => System.Unsafe.lookup i
  118.      fun package lexp = codegen (Opt.closetop(lexp,!CoreInfo.corePath)) looker
  119.   in package(instrument(reduce(undelay closure)))
  120.  end
  121.  
  122. (***> here BOGUSty should be replaced by accurate type in the future <***)
  123. and instrument lexp =
  124.  let val forcerpath = translatepath(!CoreInfo.forcerPath)
  125.      val _ = System.Unsafe.forcer_p := cast forcer
  126.      fun f(APP(PRIM(P.delay,_),b)) = delayAnalyze b
  127.        | f(PRIM(P.delay,t)) = 
  128.             let val v = mkLvar()
  129.          in f(FN(v,BOGUSty,APP(PRIM(P.delay,t),VAR v)))
  130.         end
  131.        | f(PRIM(P.force,_)) = APP(PRIM(P.!,BOGUSty),forcerpath)
  132.        | f(APP(a,b)) = APP(f a, f b)
  133.        | f(FN(v,t,b)) = FN(v,t,f b)
  134.        | f(FIX(vl,t,el,e)) = FIX(vl, t, map f el, f e)
  135.        | f(SWITCH(e,cel,SOME d)) = SWITCH(f e, map f2 cel, SOME(f d))
  136.        | f(SWITCH(e,cel,NONE)) = SWITCH(f e, map f2 cel, NONE)
  137.        | f(RECORD(el)) = RECORD(map f el)
  138.        | f(VECTOR(el)) = VECTOR(map f el)
  139.        | f(SELECT(i,e)) = SELECT(i, f e)
  140.        | f(RAISE(e,t)) = RAISE(f e, t)
  141.        | f(HANDLE(a,b)) = HANDLE(f a, f b)
  142.        | f(WRAP(t,e)) = WRAP(t, f e)
  143.        | f(UNWRAP(t,e)) = UNWRAP(t, f e)
  144.        | f e = e
  145.      and f2(c,e) = (c, f e)
  146.   in let val z = f lexp
  147.       in (MCprint.printLexp z; print "\n"); z
  148.      end
  149.  end
  150.  
  151. end
  152.