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 301 - (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 : blume 299 fun primitive (gp: GeneralParams.info) p =
36 :     { dyn = fn () => E.dynamicPart (Primitive.env
37 :     (#primconf (#param gp)) p),
38 : blume 295 dts = DTS.ancient }
39 :    
40 : blume 299 fun pervasive (gp: GeneralParams.info) =
41 :     { dyn = fn () => E.dynamicPart (#pervasive (#param gp)),
42 :     dts = DTS.ancient }
43 :    
44 :     val bpervasive = pervasive
45 :    
46 : blume 295 fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }
47 :    
48 :     fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let
49 :     val (tryshare, mustshare) =
50 :     case share of
51 :     NONE => (true, false)
52 :     | SOME true => (true, true)
53 :     | SOME false => (false, false)
54 :     fun doit () = let
55 :     val dts' = if tryshare then DTS.current ()
56 :     else DTS.noshare descr
57 :     val e = BF.exec (bfc, mkdyn ())
58 :     val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }
59 :     in
60 :     memo m;
61 :     SOME (thunkify m)
62 :     end handle exn => let
63 :     fun pphist pps =
64 :     (PP.add_string pps (General.exnMessage exn);
65 :     PP.add_newline pps)
66 :     in
67 :     error "exception in module initialization code" pphist;
68 :     NONE
69 :     end
70 :     in
71 :     if mustshare then
72 :     case DTS.can'tShare dts of
73 :     NONE => doit ()
74 :     | SOME sl => let
75 : blume 301 fun pphist [] pps = PP.add_newline pps
76 : blume 295 | pphist (h :: t) pps =
77 : blume 301 (PP.add_newline pps;
78 :     PP.add_string pps h;
79 : blume 295 pphist t pps)
80 :     in
81 :     error
82 :     "cannot share state: dependence on non-shareable modules"
83 :     (pphist sl);
84 :     NONE
85 :     end
86 :     else doit ()
87 :     end
88 :    
89 : blume 298 fun dostable (i, mkenv, gp) =
90 :     case mkenv () of
91 :     NONE => NONE
92 :     | SOME (e as { dyn, dts }) =>
93 :     (case PS.exec_look_stable (i, dts, gp) of
94 :     SOME memo => SOME (thunkify memo)
95 :     | NONE => execute (PS.bfc_fetch_stable i, e,
96 :     BinInfo.share i,
97 :     BinInfo.error gp i EM.COMPLAIN,
98 :     BinInfo.describe i,
99 :     fn m => PS.exec_memo_stable (i, m)))
100 : blume 295
101 : blume 298 fun dosml (i, e as { dyn, dts }, gp) = let
102 :     fun looksml () =
103 :     Option.map thunkify (PS.exec_look_sml (i, dts, gp))
104 :     in
105 :     case looksml () of
106 :     SOME d => SOME d
107 :     | NONE => execute (PS.bfc_fetch_sml i, e,
108 :     SmlInfo.share i,
109 :     SmlInfo.error gp i EM.COMPLAIN,
110 :     SmlInfo.name i,
111 :     fn m => PS.exec_memo_sml (i, m))
112 :     end
113 : blume 295 end

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