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/link.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 569 - (download) (annotate)
Tue Mar 7 04:01:07 2000 UTC (19 years, 4 months ago) by blume
File size: 9526 byte(s)
- size info in BOOTLIST
     * no fixed upper limits for number of bootfiles or length of
       bootfile names in runtime
     * falling back to old behavior if no BOOTLIST size info found
- allocation size heuristics in .run-sml
     * tries to read cache size from /proc/cpuinfo (this is important for
        small-cache Celeron systems!)
- install.sh robustified
- CM manual updates
- paranoid mode
     * no more CMB.deliver() (i.e., all done by CMB.make())
     * can re-use existing sml.boot.* files
     * init.cmi now treated as library
     * library stamps for consistency checks
- sml.boot.<arch>-<os>/PIDMAP file
     * This file is read by the CM startup code.  This is used to minimize
       the amount of dynamic state that needs to be stowed away for the
       purpose of sharing between interactive system and user code.
- CM.Anchor.anchor instead of CM.Anchor.{set,cancel}
     * Upon request by Elsa.  Anchors now controlled by get-set-pair
       like most other CM state variables.
- Compiler.CMSA eliminated
     * No longer supported by CM anyway.
- fixed bugs in pickler that kept biting Stefan
     * past refs to past refs (was caused by the possibility that
       ad-hoc sharing is more discriminating than hash-cons sharing)
     * integer overflow on LargeInt.minInt
- ml-{lex,yacc} build scripts now use new mechanism
  for building standalone programs
- fixed several gcc -Wall warnings that were caused by missing header
  files, missing initializations, etc., in runtime (not all warnings
  eliminated, though)
(*
 * Link traversals.
 *   - manages shared state
 *
 * (C) 1999 Lucent Technologies, Bell Laboratories
 *
 * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
 *)
local
    structure GP = GeneralParams
    structure DG = DependencyGraph
    structure GG = GroupGraph
    structure E = GenericVC.Environment
    structure BE = GenericVC.BareEnvironment
    structure DE = DynamicEnv
    structure EM = GenericVC.ErrorMsg
    structure PP = PrettyPrint

    type env = E.dynenv
in
    signature LINK = sig

	type bfc
	type bfcGetter = SmlInfo.info -> bfc

	(* Evict value from cache if it exists *)
	val evict : GP.info -> SmlInfo.info -> unit

	val evictStale : unit -> unit

	(* Check all values and evict those that depended on other
	 * meanwhile evicted ones. *)
	val cleanup : GP.info -> unit

	val newTraversal : GG.group * bfcGetter ->
	    { group: GP.info -> env option,
	      exports: (GP.info -> env option) SymbolMap.map }

	(* discard persistent state *)
	val reset : unit -> unit
    end

    functor LinkFn (structure MachDepVC : MACHDEP_VC
		    structure BFC : BFC
		    sharing type MachDepVC.Binfile.bfContent = BFC.bfc
		    val system_values : env SrcPathMap.map ref) :> LINK
	where type bfc = BFC.bfc =
    struct

	structure BF = MachDepVC.Binfile

	type bfc = BF.bfContent
	type bfcGetter = SmlInfo.info -> bfc

	type bfun = GP.info -> E.dynenv -> E.dynenv

	datatype bnode =
	    B of bfun * BinInfo.info * bnode list

	val stablemap = ref (StableMap.empty: bnode StableMap.map)

	type smemo = E.dynenv * SmlInfo.info list

	val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)

	val emptyStatic = E.staticPart E.emptyEnv
	val emptyDyn = E.dynamicPart E.emptyEnv

	fun evict gp i = let
	    fun check () =
		case SmlInfo.sh_mode i of
		    Sharing.SHARE true =>
			SmlInfo.error gp i EM.WARN
			(concat ["sharing for ",
				 SmlInfo.descr i,
				 " may be lost"])
			EM.nullErrorBody
		  | _ =>  ()
	in
	    (smlmap := #1 (SmlInfoMap.remove (!smlmap, i))
	     before check ())
	    handle LibBase.NotFound => ()
	end

	fun evictStale () =
	    smlmap := SmlInfoMap.filteri (SmlInfo.isKnown o #1) (!smlmap)

	fun cleanup gp = let
	    val visited = ref SmlInfoSet.empty
	    fun visit i =
		if SmlInfoSet.member (!visited, i) then true
		else
		    case SmlInfoMap.find (!smlmap, i) of
			NONE => false
		      | SOME (_, l) => let
			    val bl = map visit l
			    val b = List.all (fn x => x) bl
			in
			    if b then
				(visited := SmlInfoSet.add (!visited, i);
				 true)
			    else (evict gp i; false)
			end
	in
	    app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
	end

	fun newTraversal (group, getBFC) = let

	    val GG.GROUP { exports, grouppath, ... } = group

	    fun exn_err (msg, error, descr, exn) = let
		fun ppb pps =
		    (PP.add_newline pps;
		     PP.add_string pps (General.exnMessage exn);
		     PP.add_newline pps)
	    in
		error (concat [msg, " ", descr]) ppb;
		raise exn
	    end

	    (* We invoke mk_de here and only if we don't have the value
	     * available as a sysval.  This saves the (unnecessary) traversal
	     * in the stable case. (Normally all sysval entries are from
	     * stable libraries.) *)
	    fun execute sysval (bfc, mk_de, gp: GP.info) =
		case sysval (BF.exportPidOf bfc) of
		    NONE =>
			BF.exec (bfc,
				 DE.atop (mk_de gp,
					  BE.dynamicPart(#corenv (#param gp))))
		  | SOME de' => de'

	    (* Construction of the environment is delayed until we are
	     * sure we really REALLY need it.  This way we spare ourselves
	     * the trouble of doing the ancestor traversal if we
	     * end up finding out we already have the value in sysVal. *)
	    fun link_stable sysval (i, mk_e, gp) = let
		val stable = BinInfo.stablename i
		val os = BinInfo.offset i
		val descr = BinInfo.describe i
		val error = BinInfo.error i EM.COMPLAIN
		val bfc = BFC.getStable { stable = stable, offset = os,
					  descr = descr }
		    handle exn => exn_err ("unable to load library module",
					   error, descr, exn)
	    in
		execute sysval (bfc, mk_e, gp)
		handle exn =>
		    exn_err ("link-time exception in library code",
			     error, descr, exn)
	    end

	    fun link_sml (gp, i, getBFC, getE, snl) = let
		fun fresh () = let
		    val bfc = getBFC i
		in
		    case getE gp of
			NONE => NONE
		      | SOME e =>
			    (SOME (execute (fn _ => NONE) (bfc, fn _ => e, gp))
			     handle exn =>
				exn_err ("link-time exception in user program",
					 SmlInfo.error gp i EM.COMPLAIN,
					 SmlInfo.descr i,
					 exn))
		end handle _ => NONE
	    in
		case SmlInfo.sh_mode i of
		    Sharing.SHARE _ =>
			(case SmlInfoMap.find (!smlmap, i) of
			     NONE =>
				 (case fresh () of
				      NONE => NONE
				    | SOME de => let
					  val m = (de, snl)
				      in
					  smlmap :=
					    SmlInfoMap.insert (!smlmap, i, m);
					  SOME de
				      end)
			   | SOME (de, _) => SOME de)
		  | Sharing.DONTSHARE => (evict gp i; fresh ())
	    end

	    val visited = ref SrcPathSet.empty

	    fun registerGroup g = let
		val GG.GROUP { grouppath, kind, sublibs, ... } = g
		fun registerStableLib (GG.GROUP sg) = let
		    val { exports, grouppath = sgp, ... } = sg
		    val sysvals =
			let val (m', e) =
			    SrcPathMap.remove (!system_values, sgp)
			in system_values := m'; e
			end handle LibBase.NotFound => emptyDyn

		    fun sv (SOME pid) =
			(SOME (DE.bind (pid, DE.look sysvals pid, emptyDyn))
			 handle DE.Unbound => NONE)
		      | sv _ = NONE

		    val localmap = ref StableMap.empty
		    fun bn (DG.BNODE n) = let
			val { bininfo = i, localimports, globalimports } = n
			fun new () = let
			    val e0 = (fn _ => emptyDyn, [])
			    fun join ((f, NONE), (e, l)) =
				(fn gp => DE.atop (f gp emptyDyn, e gp), l)
			      | join ((f, SOME (i, l')), (e, l)) =
				(e, B (f, i, l') :: l)
			    val ge = foldl join e0 (map fbn globalimports)
			    val le = foldl join ge (map bn localimports)
			in
			    case (BinInfo.sh_mode i, le) of
				(Sharing.SHARE _, (e, [])) => let
				    fun thunk gp = link_stable sv (i, e, gp)
				    val m_thunk = Memoize.memoize thunk
				in
				    (fn gp => fn _ => m_thunk gp, NONE)
				end
			      | (Sharing.SHARE _, _) =>
				EM.impossible "Link: sh_mode inconsistent"
			      | (Sharing.DONTSHARE, (e, l)) =>
				(fn gp => fn e' =>
				 link_stable sv
				    (i, fn gp => DE.atop (e', e gp), gp),
				 SOME (i, l))
			end
		    in
			case StableMap.find (!stablemap, i) of
			    SOME (B (f, i, [])) =>
				(case BinInfo.sh_mode i of
				     Sharing.DONTSHARE => (f, SOME (i, []))
				   | _ => (f, NONE))
			  | SOME (B (f, i, l)) => (f, SOME (i, l))
			  | NONE => (case StableMap.find (!localmap, i) of
					 SOME x => x
				       | NONE => let val x = new ()
					 in localmap := StableMap.insert
					           (!localmap, i, x);
					    x
					 end)
		    end

		    and fbn (_, n) = bn n

		    fun sbn (DG.SB_SNODE n) =
			EM.impossible "Link:SNODE in stable lib"
		      | sbn (DG.SB_BNODE (n as DG.BNODE { bininfo, ... }, _)) =
			let
			    val b as B (_, i, _) =
				case bn n of
				    (f, NONE) => B (f, bininfo, [])
				  | (f, SOME (i, l)) => B (f, i, l)
			in
			    stablemap := StableMap.insert (!stablemap, i, b)
			end

		    fun fsbn (_, n) = sbn n
		    fun impexp (n, _) = fsbn n
		in
		    SymbolMap.app impexp exports
		end
	    in
		if SrcPathSet.member (!visited, grouppath) then ()
		else (visited := SrcPathSet.add (!visited, grouppath);
		      app (registerGroup o #2) sublibs;
		      case kind of
			  GG.STABLELIB _ => registerStableLib g
			| _ => ())
	    end

	    val _ = registerGroup group

	    val l_stablemap = ref StableMap.empty
	    val l_smlmap = ref SmlInfoMap.empty

	    fun bnode (B (f, i, l)) =
		case StableMap.find (!l_stablemap, i) of
		    SOME th => th
		  | NONE => let
			val fl = map bnode l
			fun th gp = let
			    fun add (t, e) = DE.atop (t gp, e)
			in
			    f gp (foldl add emptyDyn fl)
			end
			val m_th = Memoize.memoize th
		    in
			l_stablemap :=
			  StableMap.insert (!l_stablemap, i, m_th);
			m_th
		    end

	    fun sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)) = let
		    val b = valOf (StableMap.find (!stablemap, bininfo))
		    fun th gp =
			SOME (bnode b gp)
			handle exn => NONE
		in
		    (th, [])
		end
	      | sbn (DG.SB_SNODE n) = sn n

	    and sn (DG.SNODE n) = let
		val { smlinfo = i, localimports, globalimports } = n
	    in
		case SmlInfoMap.find (!l_smlmap, i) of
		    SOME th => (th, [i])
		  | NONE => let
			fun atop (NONE, _) = NONE
			  | atop (_, NONE) = NONE
			  | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
			fun add ((f, l), (f', l')) =
			    (fn gp => atop (f gp, f' gp), l @ l')
			val gi = foldl add (fn _ => SOME emptyDyn, [])
			                   (map fsbn globalimports)
			val (getE, snl) = foldl add gi (map sn localimports)
			fun thunk gp = link_sml (gp, i, getBFC, getE, snl)
			val m_thunk = Memoize.memoize thunk
		    in
			l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
			(m_thunk, [i])
		    end
	    end

	    and fsbn (_, n) = sbn n

	    fun impexp (n, _) = #1 (fsbn n)

	    val exports' = SymbolMap.map impexp exports

	    fun group' gp = let
		fun one (_, NONE) = NONE
		  | one (f, SOME e) =
		    (case f gp of
			 NONE => NONE
		       | SOME e' => SOME (DE.atop (e', e)))
	    in
		SymbolMap.foldl one (SOME emptyDyn) exports'
	    end
	in
	    { exports = exports', group = group' }
	end

	fun reset () = (stablemap := StableMap.empty;
			smlmap := SmlInfoMap.empty)
    end
end

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