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 303 - (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 303 type env = (unit -> E.dynenv) * bool
21 : blume 295 type benv = env
22 :     type envdelta = env
23 :    
24 : blume 303 fun layer ((d, n), (d', n')) = (fn () => DE.atop (d (), d'()), n orelse n')
25 : blume 295
26 :     fun filter (e, _) = e
27 :     fun nofilter e = e
28 :    
29 :     val blayer = layer
30 :     val bfilter = filter
31 :     val bnofilter = nofilter
32 :    
33 : blume 299 fun primitive (gp: GeneralParams.info) p =
34 : blume 303 (fn () => E.dynamicPart (Primitive.env (#primconf (#param gp)) p),
35 :     false)
36 : blume 295
37 : blume 299 fun pervasive (gp: GeneralParams.info) =
38 : blume 303 (fn () => E.dynamicPart (#pervasive (#param gp)), false)
39 : blume 299
40 :     val bpervasive = pervasive
41 :    
42 : blume 303 fun thunkify (d, n) = (fn () => d, n)
43 : blume 295
44 : blume 303 fun execute (bfc, (mkdyn, newCtxt), error, descr, memo) = let
45 :     val e = BF.exec (bfc, mkdyn ())
46 :     val de = E.dynamicPart e
47 : blume 295 in
48 : blume 303 memo de;
49 :     SOME (thunkify (de, newCtxt))
50 :     end handle exn => let
51 :     fun ppb pps =
52 :     (PP.add_newline pps;
53 :     PP.add_string pps (General.exnMessage exn);
54 :     PP.add_newline pps)
55 :     in
56 :     error ("link-time error in " ^ descr) ppb;
57 :     NONE
58 : blume 295 end
59 :    
60 : blume 298 fun dostable (i, mkenv, gp) =
61 :     case mkenv () of
62 :     NONE => NONE
63 : blume 303 | SOME (e as (dyn, newCtxt)) =>
64 :     (case PS.exec_look_stable (i, newCtxt, gp) of
65 :     SOME m => SOME (thunkify m)
66 : blume 298 | NONE => execute (PS.bfc_fetch_stable i, e,
67 :     BinInfo.error gp i EM.COMPLAIN,
68 :     BinInfo.describe i,
69 : blume 303 fn e => PS.exec_memo_stable (i, e)))
70 : blume 295
71 : blume 303 fun dosml (i, e as (dyn, newCtxt), gp) =
72 :     case PS.exec_look_sml (i, newCtxt, gp) of
73 :     SOME m => SOME (thunkify m)
74 : blume 298 | NONE => execute (PS.bfc_fetch_sml i, e,
75 :     SmlInfo.error gp i EM.COMPLAIN,
76 :     SmlInfo.name i,
77 :     fn m => PS.exec_memo_sml (i, m))
78 : blume 295 end

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