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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 302, Sat May 29 03:19:59 1999 UTC revision 303, Sun May 30 10:23:20 1999 UTC
# Line 12  Line 12 
12  functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct  functor ExecFn (structure PS : FULL_PERSSTATE) : COMPILATION_TYPE = struct
13    
14      structure E = GenericVC.Environment      structure E = GenericVC.Environment
     structure DTS = DynTStamp  
15      structure DE = GenericVC.DynamicEnv      structure DE = GenericVC.DynamicEnv
16      structure BF = PS.MachDepVC.Binfile      structure BF = PS.MachDepVC.Binfile
17      structure PP = PrettyPrint      structure PP = PrettyPrint
18      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
19    
20      type env = { dyn: unit -> E.dynenv, dts: DTS.dts }      type env = (unit -> E.dynenv) * bool
21      type benv = env      type benv = env
22      type envdelta = env      type envdelta = env
23    
24      fun layer ({ dyn = d, dts = s }, { dyn = d', dts = s' }) =      fun layer ((d, n), (d', n')) = (fn () => DE.atop (d (), d'()), n orelse n')
         { dyn = fn () => DE.atop (d (), d' ()), dts = DTS.join (s, s') }  
25    
26      fun filter (e, _) = e      fun filter (e, _) = e
27      fun nofilter e = e      fun nofilter e = e
# Line 33  Line 31 
31      val bnofilter = nofilter      val bnofilter = nofilter
32    
33      fun primitive (gp: GeneralParams.info) p =      fun primitive (gp: GeneralParams.info) p =
34          { dyn = fn () => E.dynamicPart (Primitive.env          (fn () => E.dynamicPart (Primitive.env (#primconf (#param gp)) p),
35                                          (#primconf (#param gp)) p),           false)
           dts = DTS.ancient }  
36    
37      fun pervasive (gp: GeneralParams.info) =      fun pervasive (gp: GeneralParams.info) =
38          { dyn = fn () => E.dynamicPart (#pervasive (#param gp)),          (fn () => E.dynamicPart (#pervasive (#param gp)), false)
           dts = DTS.ancient }  
39    
40      val bpervasive = pervasive      val bpervasive = pervasive
41    
42      fun thunkify { dyn, dts } = { dyn = fn () => dyn, dts = dts }      fun thunkify (d, n) = (fn () => d, n)
43    
44      fun execute (bfc, { dyn = mkdyn, dts }, share, error, descr, memo) = let      fun execute (bfc, (mkdyn, newCtxt), error, descr, memo) = let
         val (tryshare, mustshare) =  
             case share of  
                 NONE => (true, false)  
               | SOME true => (true, true)  
               | SOME false => (false, false)  
         fun doit () = let  
             val dts' = if tryshare then DTS.current ()  
                        else DTS.noshare descr  
45              val e = BF.exec (bfc, mkdyn ())              val e = BF.exec (bfc, mkdyn ())
46              val m = { dyn = E.dynamicPart e, dts = DTS.join (dts, dts') }          val de = E.dynamicPart e
47          in          in
48              memo m;          memo de;
49              SOME (thunkify m)          SOME (thunkify (de, newCtxt))
50          end handle exn => let          end handle exn => let
51              fun ppb pps =              fun ppb pps =
52                  (PP.add_newline pps;                  (PP.add_newline pps;
# Line 68  Line 56 
56              error ("link-time error in " ^ descr) ppb;              error ("link-time error in " ^ descr) ppb;
57              NONE              NONE
58          end          end
     in  
         if mustshare then  
             case DTS.can'tShare dts of  
                 NONE => doit ()  
               | SOME sl => let  
                     fun ppb pps = let  
                         fun loop [] = ()  
                           | loop (h :: t) =  
                             (PP.add_string pps h; PP.add_newline pps; loop t)  
                     in  
                         PP.add_newline pps;  
                         PP.add_string pps  
                                 "because of dependence on private module(s):";  
                         PP.add_newline pps;  
                         loop sl  
                     end  
                 in  
                     error ("cannot share state of " ^ descr) ppb;  
                     NONE  
                 end  
         else doit ()  
     end  
59    
60      fun dostable (i, mkenv, gp) =      fun dostable (i, mkenv, gp) =
61          case mkenv () of          case mkenv () of
62              NONE => NONE              NONE => NONE
63            | SOME (e as { dyn, dts }) =>            | SOME (e as (dyn, newCtxt)) =>
64                  (case PS.exec_look_stable (i, dts, gp) of                  (case PS.exec_look_stable (i, newCtxt, gp) of
65                       SOME memo => SOME (thunkify memo)                       SOME m => SOME (thunkify m)
66                     | NONE => execute (PS.bfc_fetch_stable i, e,                     | NONE => execute (PS.bfc_fetch_stable i, e,
                                       BinInfo.share i,  
67                                        BinInfo.error gp i EM.COMPLAIN,                                        BinInfo.error gp i EM.COMPLAIN,
68                                        BinInfo.describe i,                                        BinInfo.describe i,
69                                        fn m => PS.exec_memo_stable (i, m)))                                        fn e => PS.exec_memo_stable (i, e)))
70    
71      fun dosml (i, e as { dyn, dts }, gp) =      fun dosml (i, e as (dyn, newCtxt), gp) =
72          case PS.exec_look_sml (i, dts, gp) of          case PS.exec_look_sml (i, newCtxt, gp) of
73              SOME memo => SOME (thunkify memo)              SOME m => SOME (thunkify m)
74            | NONE => execute (PS.bfc_fetch_sml i, e,            | NONE => execute (PS.bfc_fetch_sml i, e,
                              SmlInfo.share i,  
75                               SmlInfo.error gp i EM.COMPLAIN,                               SmlInfo.error gp i EM.COMPLAIN,
76                               SmlInfo.name i,                               SmlInfo.name i,
77                               fn m => PS.exec_memo_sml (i, m))                               fn m => PS.exec_memo_sml (i, m))

Legend:
Removed from v.302  
changed lines
  Added in v.303

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