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/full-persstate-fn.sml
ViewVC logotype

View of /sml/trunk/src/cm/compile/full-persstate-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 302 - (download) (annotate)
Sat May 29 03:19:59 1999 UTC (21 years, 6 months ago) by blume
File size: 2684 byte(s)
bug in handling of private flag fixed
(*
 * Build a new "full" persistent state.
 *
 * (C) 1999 Lucent Technologies, Bell Laboratories
 *
 * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
 *)
functor FullPersstateFn (structure MachDepVC : MACHDEP_VC) :> FULL_PERSSTATE =
    struct
	structure E = GenericVC.Environment
	structure DTS = DynTStamp

	type exec_memo = { dyn: E.dynenv, dts: DTS.dts }

	val smlmap = ref (AbsPathMap.empty: exec_memo AbsPathMap.map)
	val stablemap = ref (StableMap.empty: exec_memo StableMap.map)

	local
	    fun discard_value i = let
		val p = SmlInfo.sourcepath i
		val m = !smlmap
		val m' =
		    #1 (AbsPathMap.remove (m, p))
		    handle LibBase.NotFound => m
	    in
		smlmap := m'
	    end
	    structure RecompPersstate =
		RecompPersstateFn (structure MachDepVC = MachDepVC
				   val discard_code = false
				   val discard_value = discard_value)
	in
	    open RecompPersstate
	end

	infix o' o''
	fun (f o' g) (x, y) = f (g x, y)
	fun (f o'' g) (x, y, z) = f (g x, y, z)

	datatype key =
	    SML of SmlInfo.info
	  | STABLE of BinInfo.info

	fun find (SML i) = AbsPathMap.find (!smlmap, SmlInfo.sourcepath i)
	  | find (STABLE i) = StableMap.find (!stablemap, i)

	fun insert (SML i, m) =
	    smlmap := AbsPathMap.insert (!smlmap, SmlInfo.sourcepath i, m)
	  | insert (STABLE i, m) =
	    stablemap := StableMap.insert (!stablemap, i, m)

	fun remove (SML i) =
	    smlmap := #1 (AbsPathMap.remove (!smlmap, SmlInfo.sourcepath i))
	  | remove (STABLE i) =
	    stablemap := #1 (StableMap.remove (!stablemap, i))

	fun share (SML i) = SmlInfo.share i
	  | share (STABLE i) = BinInfo.share i

	fun error gp (SML i) = SmlInfo.error gp i
	  | error gp (STABLE i) = BinInfo.error gp i

	fun descr (SML i) = SmlInfo.name i
	  | descr (STABLE i) = BinInfo.describe i

	fun exec_look (i, s, gp) =
	    case find i of
		NONE => NONE
	      | SOME (memo as { dts = s', ... }) => let
		    fun warn () =
			error gp i GenericVC.ErrorMsg.WARN
			      (concat ["reinstantiating ", descr i,
				       " (sharing may be lost)"])
			      GenericVC.ErrorMsg.nullErrorBody
		in
		    if DTS.outdated { context = s, oldresult = s' } then
			(if share i = SOME true then warn () else ();
			 (remove i; NONE))
		    else SOME memo
		end

	fun exec_memo (i, memo) = insert (i, memo)

	val exec_look_sml = exec_look o'' SML
	val exec_look_stable = exec_look o'' STABLE
	val exec_memo_sml = exec_memo o' SML
	val exec_memo_stable = exec_memo o' STABLE

	fun forgetNonShared () = let
	    fun isShareable { dyn, dts } =
		not (isSome (DynTStamp.can'tShare dts))
	in
	    smlmap := AbsPathMap.filter isShareable (!smlmap);
	    stablemap := StableMap.filter isShareable (!stablemap)
	end
    end

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