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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 298 - (view) (download)

1 : blume 295 (*
2 :     * Build an argument for the generic compilation functor.
3 :     * This gives a traversal that executes the code in each node as
4 :     * necessary (and builds the dynamic environment).
5 :     * A traversal requires prior successful traversal using the
6 :     * "RecompFn" functor (using the same persistent state).
7 :     *
8 :     * (C) 1999 Lucent Technologies, Bell Laboratories
9 :     *
10 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :     *)
12 :     functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct
13 :    
14 :     structure E = GenericVC.Environment
15 :     structure DTS = DynTStamp
16 :     structure DE = GenericVC.DynamicEnv
17 :     structure BF = PS.MachDepVC.Binfile
18 :     structure PP = PrettyPrint
19 :     structure EM = GenericVC.ErrorMsg
20 :    
21 :     type env = { dyn: unit -> E.dynenv, dts: DTS.dts }
22 :     type benv = env
23 :     type envdelta = env
24 :    
25 :     fun layer ({ dyn = d, dts = s }, { dyn = d', dts = s' }) =
26 :     { dyn = fn () => DE.atop (d (), d' ()), dts = DTS.join (s, s') }
27 :    
28 :     fun filter (e, _) = e
29 :     fun nofilter e = e
30 :    
31 :     val blayer = layer
32 :     val bfilter = filter
33 :     val bnofilter = nofilter
34 :    
35 :     fun primitive c p =
36 :     { dyn = fn () => E.dynamicPart (Primitive.env c p),
37 :     dts = DTS.ancient }
38 :    
39 :     fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }
40 :    
41 :     fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
42 :     val (tryshare, mustshare) =
43 :     case share of
44 :     NONE => (true, false)
45 :     | SOME true => (true, true)
46 :     | SOME false => (false, false)
47 :     fun doit () = let
48 :     val dts' = if tryshare then DTS.current ()
49 :     else DTS.noshare descr
50 :     val e = BF.exec (bfc, mkdyn ())
51 :     val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
52 :     in
53 :     memo m;
54 :     SOME (thunkify m)
55 :     end handle exn => let
56 :     fun pphist pps =
57 :     (PP.add_string pps (General.exnMessage exn);
58 :     PP.add_newline pps)
59 :     in
60 :     error "exception in module initialization code" pphist;
61 :     NONE
62 :     end
63 :     in
64 :     if mustshare then
65 :     case DTS.can'tShare dts of
66 :     NONE => doit ()
67 :     | SOME sl => let
68 :     fun pphist [] pps = ()
69 :     | pphist (h :: t) pps =
70 :     (PP.add_string pps h;
71 :     PP.add_newline pps;
72 :     pphist t pps)
73 :     in
74 :     error
75 :     "cannot share state: dependence on non-shareable modules"
76 :     (pphist sl);
77 :     NONE
78 :     end
79 :     else doit ()
80 :     end
81 :    
82 : blume 298 fun dostable (i, mkenv, gp) =
83 :     case mkenv () of
84 :     NONE => NONE
85 :     | SOME (e as { dyn, dts }) =>
86 :     (case PS.exec_look_stable (i, dts, gp) of
87 :     SOME memo => SOME (thunkify memo)
88 :     | NONE => execute (PS.bfc_fetch_stable i, e,
89 :     BinInfo.share i,
90 :     BinInfo.error gp i EM.COMPLAIN,
91 :     BinInfo.describe i,
92 :     fn m => PS.exec_memo_stable (i, m)))
93 : blume 295
94 : blume 298 fun dosml (i, e as { dyn, dts }, gp) = let
95 :     fun looksml () =
96 :     Option.map thunkify (PS.exec_look_sml (i, dts, gp))
97 :     in
98 :     case looksml () of
99 :     SOME d => SOME d
100 :     | NONE => execute (PS.bfc_fetch_sml i, e,
101 :     SmlInfo.share i,
102 :     SmlInfo.error gp i EM.COMPLAIN,
103 :     SmlInfo.name i,
104 :     fn m => PS.exec_memo_sml (i, m))
105 :     end
106 : blume 295 end

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