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 354 - (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 DE = GenericVC.DynamicEnv
16 :     structure BF = PS.MachDepVC.Binfile
17 :     structure PP = PrettyPrint
18 :     structure EM = GenericVC.ErrorMsg
19 :    
20 : blume 320 type env = (unit -> E.dynenv) * SmlInfo.info list * BinInfo.info list
21 : blume 295 type benv = env
22 :     type envdelta = env
23 : blume 314 type result = E.dynenv
24 : blume 295
25 : blume 320 fun layer ((d, sl, bl), (d', sl', bl')) =
26 :     (fn () => DE.atop (d (), d' ()), sl @ sl', bl @ bl')
27 : blume 295
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 314 val empty = DE.empty
36 : blume 320 fun env2result ((mkEnv, _, _): env) = mkEnv ()
37 : blume 314 fun rlayer (r, r') = DE.atop (r, r')
38 :    
39 : blume 299 fun primitive (gp: GeneralParams.info) p =
40 : blume 303 (fn () => E.dynamicPart (Primitive.env (#primconf (#param gp)) p),
41 : blume 320 [], [])
42 : blume 295
43 : blume 299 fun pervasive (gp: GeneralParams.info) =
44 : blume 320 (fn () => E.dynamicPart (#pervasive (#param gp)),
45 :     [], [])
46 : blume 299
47 :     val bpervasive = pervasive
48 :    
49 : blume 320 fun thunkify d () = d
50 : blume 295
51 : blume 320 fun execute (bfc, mkdyn, error, descr, memo, sl, bl) = let
52 : blume 303 val e = BF.exec (bfc, mkdyn ())
53 :     val de = E.dynamicPart e
54 : blume 295 in
55 : blume 303 memo de;
56 : blume 320 SOME (thunkify de, sl, bl)
57 : blume 303 end handle exn => let
58 :     fun ppb pps =
59 :     (PP.add_newline pps;
60 :     PP.add_string pps (General.exnMessage exn);
61 :     PP.add_newline pps)
62 :     in
63 :     error ("link-time error in " ^ descr) ppb;
64 :     NONE
65 : blume 295 end
66 :    
67 : blume 320 fun dostable (i, mkbenv, gp) =
68 :     case mkbenv () of
69 : blume 298 NONE => NONE
70 : blume 320 | SOME (benv, sl, bl) =>
71 :     (case PS.exec_look_stable (i, gp) of
72 :     SOME m => SOME (thunkify m, [], [i])
73 :     | NONE => (execute (PS.bfc_fetch_stable i, benv,
74 :     BinInfo.error i EM.COMPLAIN,
75 :     BinInfo.describe i,
76 :     fn e => PS.exec_memo_stable (i, e, bl),
77 :     [], [i])))
78 :    
79 :     fun fetch_sml i =
80 :     PS.bfc_fetch_sml i handle e => (print "!!! fetch_sml\n"; raise e)
81 : blume 295
82 : blume 320 fun dosml (i, (env, sl, bl), gp) =
83 :     case PS.exec_look_sml (i, gp) of
84 :     SOME m => SOME (thunkify m, [i], [])
85 :     | NONE => (execute (fetch_sml i, env,
86 :     SmlInfo.error gp i EM.COMPLAIN,
87 : blume 354 SmlInfo.descr i,
88 : blume 320 fn m => PS.exec_memo_sml (i, m, sl, bl),
89 :     [i], []))
90 : blume 295 end

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