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 369 - (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 : blume 369 functor ExecFn (structure PS : FULL_PERSSTATE) : sig
13 :     structure Recomp : COMPILATION_TYPE
14 :     structure RecompTraversal : TRAVERSAL
15 :     structure Exec : COMPILATION_TYPE
16 :     end = struct
17 : blume 295
18 : blume 369 structure Recomp = RecompFn (structure PS = PS)
19 :     structure RecompTraversal = CompileGenericFn (structure CT = Recomp)
20 :    
21 :     structure Exec = struct
22 : blume 295 structure E = GenericVC.Environment
23 :     structure DE = GenericVC.DynamicEnv
24 :     structure BF = PS.MachDepVC.Binfile
25 :     structure PP = PrettyPrint
26 :     structure EM = GenericVC.ErrorMsg
27 :    
28 : blume 320 type env = (unit -> E.dynenv) * SmlInfo.info list * BinInfo.info list
29 : blume 295 type benv = env
30 :     type envdelta = env
31 : blume 314 type result = E.dynenv
32 : blume 295
33 : blume 361 fun reset () = ()
34 :    
35 : blume 320 fun layer ((d, sl, bl), (d', sl', bl')) =
36 :     (fn () => DE.atop (d (), d' ()), sl @ sl', bl @ bl')
37 : blume 295
38 :     fun filter (e, _) = e
39 :     fun nofilter e = e
40 :    
41 :     val blayer = layer
42 :     val bfilter = filter
43 :     val bnofilter = nofilter
44 :    
45 : blume 314 val empty = DE.empty
46 : blume 320 fun env2result ((mkEnv, _, _): env) = mkEnv ()
47 : blume 314 fun rlayer (r, r') = DE.atop (r, r')
48 :    
49 : blume 299 fun primitive (gp: GeneralParams.info) p =
50 : blume 303 (fn () => E.dynamicPart (Primitive.env (#primconf (#param gp)) p),
51 : blume 320 [], [])
52 : blume 295
53 : blume 299 fun pervasive (gp: GeneralParams.info) =
54 : blume 320 (fn () => E.dynamicPart (#pervasive (#param gp)),
55 :     [], [])
56 : blume 299
57 :     val bpervasive = pervasive
58 :    
59 : blume 320 fun thunkify d () = d
60 : blume 295
61 : blume 320 fun execute (bfc, mkdyn, error, descr, memo, sl, bl) = let
62 : blume 303 val e = BF.exec (bfc, mkdyn ())
63 :     val de = E.dynamicPart e
64 : blume 295 in
65 : blume 362 BF.discardCode bfc;
66 : blume 303 memo de;
67 : blume 320 SOME (thunkify de, sl, bl)
68 : blume 303 end handle exn => let
69 :     fun ppb pps =
70 :     (PP.add_newline pps;
71 :     PP.add_string pps (General.exnMessage exn);
72 :     PP.add_newline pps)
73 :     in
74 :     error ("link-time error in " ^ descr) ppb;
75 :     NONE
76 : blume 295 end
77 :    
78 : blume 369 fun dostable (i, mkbenv, gp, bn) =
79 :     case mkbenv () of
80 :     NONE => NONE
81 :     | SOME (benv, sl, bl) =>
82 :     (case RecompTraversal.bnode gp bn of
83 :     SOME { bfc = SOME bfc, ... } =>
84 :     (case PS.exec_look_stable (i, gp, BF.exportPidOf bfc) of
85 :     SOME m =>
86 :     (BF.discardCode bfc;
87 :     SOME (thunkify m, [], [i]))
88 :     | NONE => (execute
89 :     (bfc, benv,
90 : blume 362 BinInfo.error i EM.COMPLAIN,
91 :     BinInfo.describe i,
92 :     fn e => PS.exec_memo_stable (i, e, bl),
93 : blume 369 [], [i])))
94 :     | _ => NONE)
95 : blume 295
96 : blume 369 fun dosml (i, (env, sl, bl), gp, sn) =
97 :     case RecompTraversal.snode gp sn of
98 :     SOME { bfc = SOME bfc, ... } =>
99 :     (case PS.exec_look_sml (i, gp, BF.exportPidOf bfc) of
100 :     SOME m =>
101 :     (BF.discardCode bfc;
102 :     SOME (thunkify m, [i], []))
103 :     | NONE => (execute (bfc, env,
104 :     SmlInfo.error gp i EM.COMPLAIN,
105 :     SmlInfo.descr i,
106 :     fn m => PS.exec_memo_sml (i, m, sl, bl),
107 :     [i], [])))
108 :     | _ => NONE
109 :    
110 :     val nestedTraversalReset = RecompTraversal.reset
111 :     end
112 : blume 295 end

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