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

SCM Repository

[smlnj] View of /sml/trunk/src/cm/compile/exec.sml
ViewVC logotype

View of /sml/trunk/src/cm/compile/exec.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 297 - (download) (annotate)
Thu May 27 08:29:19 1999 UTC (20 years, 5 months ago) by blume
File size: 3045 byte(s)
persistent state/error handling bogosity fixed
(*
 * Build an argument for the generic compilation functor.
 *   This gives a traversal that executes the code in each node as
 *   necessary (and builds the dynamic environment).
 *   A traversal requires prior successful traversal using the
 *   "RecompFn" functor (using the same persistent state).
 *
 * (C) 1999 Lucent Technologies, Bell Laboratories
 *
 * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
 *)
functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct

    structure E = GenericVC.Environment
    structure DTS = DynTStamp
    structure DE = GenericVC.DynamicEnv
    structure BF = PS.MachDepVC.Binfile
    structure PP = PrettyPrint
    structure EM = GenericVC.ErrorMsg

    type env = { dyn: unit -> E.dynenv, dts: DTS.dts }
    type benv = env
    type envdelta = env

    datatype lookstable_result =
	FOUND of envdelta
      | NOTFOUND of benv option

    fun layer ({ dyn = d, dts = s }, { dyn = d', dts = s' }) =
	{ dyn = fn () => DE.atop (d (), d' ()), dts = DTS.join (s, s') }

    fun filter (e, _) = e
    fun nofilter e = e

    val blayer = layer
    val bfilter = filter
    val bnofilter = nofilter

    fun primitive c p =
	{ dyn = fn () => E.dynamicPart (Primitive.env c p),
	  dts = DTS.ancient }

    fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }

    fun lookstable (i, mkenv, gp) =
	case mkenv () of
	    NONE => NOTFOUND NONE
	  | SOME (e as { dyn, dts }) =>
		(case PS.exec_look_stable (i, dts, gp) of
		     SOME memo => FOUND (thunkify memo)
		   | NONE => NOTFOUND (SOME e))

    fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
	val (tryshare, mustshare) =
	    case share of
		NONE => (true, false)
	      | SOME true => (true, true)
	      | SOME false => (false, false)
	fun doit () = let
	    val dts' = if tryshare then DTS.current ()
		       else DTS.noshare descr
	    val e = BF.exec (bfc, mkdyn ())
	    val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
	in
	    memo m;
	    SOME (thunkify m)
	end handle exn => let
	    fun pphist pps =
		(PP.add_string pps (General.exnMessage exn);
		 PP.add_newline pps)
	in
	    error "exception in module initialization code" pphist;
	    NONE
	end
    in
	if mustshare then
	    case DTS.can'tShare dts of
		NONE => doit ()
	      | SOME sl => let
		    fun pphist [] pps = ()
		      | pphist (h :: t) pps =
			(PP.add_string pps h;
			 PP.add_newline pps;
			 pphist t pps)
		in
		    error
		      "cannot share state: dependence on non-shareable modules"
		      (pphist sl);
		    NONE
		end
	else doit ()
    end

    fun dostable (i, e, gp) =
	execute (PS.bfc_fetch_stable i, e,
		 BinInfo.share i,
		 BinInfo.error gp i EM.COMPLAIN,
		 BinInfo.describe i,
		 fn m => PS.exec_memo_stable (i, m))

    fun looksml (i, { dyn, dts }, gp) =
	Option.map thunkify (PS.exec_look_sml (i, dts, gp))

    fun dosml (i, e, gp) =
	execute (PS.bfc_fetch_sml i, e,
		 SmlInfo.share i,
		 SmlInfo.error gp i EM.COMPLAIN,
		 SmlInfo.name i,
		 fn m => PS.exec_memo_sml (i, m))
end

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