home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / build / computil.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  4.0 KB  |  136 lines

  1. (* Copyright 1992 by AT&T Bell Laboratories *)
  2.  
  3. signature COMPUTIL =
  4. sig
  5.   exception Abort
  6.   exception Eof
  7.  
  8.   val timemsg : string -> System.Timer.time -> bool
  9.   val infomsg : string -> System.Timer.time -> bool
  10.   val debugmsg : string -> bool
  11.  
  12.   val translate : Modules.env * Absyn.dec * Source.inputSource
  13.                   -> Access.lvar list * Lambda.lexp
  14.   val transStrb : Modules.env * Absyn.strb * Source.inputSource
  15.                   -> Lambda.lexp
  16.   val transFctb : Modules.env * Absyn.fctb * Source.inputSource
  17.                   -> Lambda.lexp
  18.  
  19.   val isolate : ('a -> 'b) -> 'a -> 'b
  20.  
  21.   val convert : Lambda.lexp -> CPS.function
  22.  
  23.   val gengetty : InverseEnv.invenv -> (Access.lvar -> Lambda.lty)
  24. end
  25.  
  26.  
  27. structure CompUtil : COMPUTIL =
  28. struct
  29.  
  30.   open Access Modules Absyn System.Timer
  31.  
  32.   val update = System.Stats.update
  33.  
  34.   (* conditional message functions *)
  35.   fun printmsg (flag: bool ref) (msg: string) : bool =
  36.       if !flag
  37.       then (app System.Print.say[msg, "\n"]; System.Print.flush(); true)
  38.       else false
  39.  
  40.   fun timemsg s t = printmsg System.Control.timings 
  41.             (implode[s,", ",makestring t,"s"])
  42.   val debugmsg = printmsg System.Control.debugging    
  43.   fun infomsg s t = timemsg s t orelse debugmsg s
  44.  
  45.   exception Abort 
  46.   exception Eof
  47.  
  48.   fun translate(env,absyn,source) =
  49.       let val timer = start_timer()
  50.       val newlvars = Linkage.getvars absyn
  51.       val absyn' = SProf.instrumDec source (Prof.instrumDec(absyn))
  52.           val lambda = Translate.transDec env (ErrorMsg.error source)
  53.               (ErrorMsg.matchErrorString source) absyn'
  54.                           (Lambda.RECORD (map Lambda.VAR newlvars))
  55.       val time = check_timer timer
  56.        in update(System.Stats.translate,time);
  57.       infomsg "translate" time;
  58.       (newlvars, lambda)
  59.       end
  60.  
  61.   fun transStrb(env,sb,source) =
  62.       let val timer = start_timer()
  63.       val sb = Prof.instrumStrb sb
  64.       val STRB{strvar=STRvar{access=PATH[v],...},...} = sb
  65.       val lam = Translate.transDec env (ErrorMsg.error source)
  66.                   (ErrorMsg.matchErrorString source)
  67.                   (Absyn.STRdec[sb]) (Lambda.VAR v)
  68.       val time = check_timer timer
  69.        in update(System.Stats.translate,time);
  70.       infomsg "translate" time;
  71.       lam
  72.       end
  73.  
  74.   fun transFctb(env,fb,source) =
  75.       let val timer = start_timer()
  76.       val fb = Prof.instrumFctb fb
  77.       val FCTB{fctvar=FCTvar{access=PATH[v],...},...} = fb
  78.       val lam = Translate.transDec env (ErrorMsg.error source)
  79.             (ErrorMsg.matchErrorString source)
  80.                 (Absyn.FCTdec[fb]) (Lambda.VAR v)
  81.       val time = check_timer timer
  82.        in update(System.Stats.translate,time);
  83.       infomsg "translate" time;
  84.       lam
  85.       end
  86.  
  87.   exception Top_level_callcc
  88.  
  89.   local val cont_stack = ref (nil : unit ref list)
  90.  
  91.   in fun isolate f x = (* Just like f x, except that it catches
  92.                top-level callcc's  *)
  93.    let val r = ref()
  94.        val _ = cont_stack := r :: !cont_stack;
  95.        fun pop_stack() =
  96.        case !cont_stack
  97.         of r' :: rest => (cont_stack := rest;
  98.                   if r<>r' then raise Top_level_callcc else ())
  99.          | _ => raise Top_level_callcc (* can this ever happen? *)
  100.        val a = f x 
  101.            handle e => (pop_stack(); raise e)
  102.     in pop_stack (); 
  103.        a
  104.    end
  105.   end
  106.  
  107.   fun convert lambda =
  108.       let val timer = start_timer()
  109.       val _ = if !System.Control.CG.printLambda
  110.               then MCprint.printLexp lambda
  111.           else ()
  112.       val lambda = LambdaOpt.lambdaopt lambda
  113.       val _ = if !System.Control.CG.printLambda
  114.               then MCprint.printLexp lambda
  115.           else ()
  116.       val lambda = Reorder.reorder lambda
  117.       val _ = if !System.Control.CG.printLambda
  118.               then MCprint.printLexp lambda
  119.           else ()
  120.       val time0 = check_timer timer
  121.       val _ = infomsg "codeopt" time0
  122.       val (function,_) =  Convert.convert lambda
  123.       val time = sub_time(check_timer timer, time0)
  124.       in  update(System.Stats.codeopt,time0);
  125.       update(System.Stats.convert,time);
  126.       infomsg "convert" time;
  127.       function
  128.       end
  129.  
  130.    fun gengetty ienv =
  131.         (fn v => ((#ty(InverseEnv.look ienv v))
  132.                    handle InverseEnv.Unbound => ((!CoreInfo.coreLty) v)))
  133.  
  134.  
  135. end (* structure CompUtil *)
  136.