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/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 251, Mon Apr 19 02:55:26 1999 UTC revision 733, Fri Nov 17 05:13:45 2000 UTC
# Line 77  Line 77 
77    
78  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
79  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
80  fun sorted x = Sort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
81  fun sortrec x = Sort.sort elemgtr x  fun sortrec x = ListMergeSort.sort elemgtr x
82    
83  (** check if an access is external *)  (** check if an access is external *)
84  fun extern (DA.EXTERN _) = true  fun extern (DA.EXTERN _) = true
# Line 99  Line 99 
99   ****************************************************************************)   ****************************************************************************)
100    
101  fun transDec (rootdec, exportLvars, env,  fun transDec (rootdec, exportLvars, env,
102                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =                compInfo as {errorMatch,error,...}: CB.compInfo) =
103  let  let
104    
105  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
# Line 120  Line 120 
120    
121  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
122  fun coreLookup(id, env) =  fun coreLookup(id, env) =
123    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
124        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
125     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
126    end    end
# Line 159  Line 159 
159    
160  fun complain s = error (!region) s  fun complain s = error (!region) s
161  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
162    fun repPolyEq () =
163        if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
164        else ()
165    
166  end (* markexn-local *)  end (* markexn-local *)
167    
# Line 171  Line 174 
174    
175  (** hashkey of accesspath + accesspath + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
176  type info = (key * int list * lvar)  type info = (key * int list * lvar)
177  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
178        IntHashTable.mkTable(32,HASHTABLE)
179  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
180    
181  fun buildHdr v =  fun buildHdr v =
182    let val info = Intmap.map hashtable v    let val info = IntHashTable.lookup hashtable v
183        fun h((_, l, w), hdr) =        fun h((_, l, w), hdr) =
184               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
185                in fn e => hdr(LET(w, le, e))                in fn e => hdr(LET(w, le, e))
# Line 185  Line 189 
189    
190  fun bindvar (v, [], _) =  v  fun bindvar (v, [], _) =  v
191    | bindvar (v, l, nameOp) =    | bindvar (v, l, nameOp) =
192        let val info = (Intmap.map hashtable v) handle _ => []        let val info = (IntHashTable.lookup hashtable v) handle _ => []
193            val key = hashkey l            val key = hashkey l
194            fun h [] =            fun h [] =
195                  let val u = mkvN nameOp                  let val u = mkvN nameOp
196                   in Intmap.add hashtable (v,(key,l,u)::info); u                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
197                  end                  end
198              | h((k',l',w)::r) =              | h((k',l',w)::r) =
199                  if (k' = key) then (if (l'=l) then w else h r) else h r                  if (k' = key) then (if (l'=l) then w else h r) else h r
# Line 237  Line 241 
241  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
242    
243  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
244    (let val pinfo = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
245         val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)        of NONE =>
     in persmap := Map.add(Map.delete(pid, !persmap), pid, npinfo); var  
    end handle Map.MapF =>  
246           let val (pinfo, var) = mkPidInfo (t, l, nameOp)           let val (pinfo, var) = mkPidInfo (t, l, nameOp)
247            in persmap := Map.add(!persmap, pid, pinfo); var             in persmap := Map.insert(!persmap, pid, pinfo);
248           end)                var
249              end
250           | SOME pinfo =>
251              let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
252                  fun rmv (key, map) =
253                      let val (newMap, _) = Map.remove(map, key)
254                      in newMap
255                      end handle e => map
256               in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
257                  var
258              end
259    
260  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
261  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
# Line 271  Line 283 
283   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
284   *)   *)
285  fun coreExn id =  fun coreExn id =
286    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
287       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
288            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
289                val nrep = mkRep(rep, nt, name)                val nrep = mkRep(rep, nt, name)
# Line 281  Line 293 
293     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
294    
295  and coreAcc id =  and coreAcc id =
296    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
297       of V.VAL(V.VALvar{access, typ, path, ...}) =>       of V.VAL(V.VALvar{access, typ, path, ...}) =>
298             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
299        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
# Line 371  Line 383 
383                        end))                        end))
384    
385        fun getPolyEq () =        fun getPolyEq () =
386          (case (!polyEqRef)          (repPolyEq();
387             case (!polyEqRef)
388            of SOME e => e            of SOME e => e
389             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
390                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
# Line 908  Line 921 
921    
922  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
923    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
924          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
925              (case access of
926                   DA.LVAR v =>
927                let val knds = map tpsKnd argtycs                let val knds = map tpsKnd argtycs
928                    val nd = DI.next d                    val nd = DI.next d
929                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
930                    val hdr = buildHdr v                    val hdr = buildHdr v
931                    (* binding of all v's components *)                    (* binding of all v's components *)
932                 in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))                 in
933                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
934                end                end
935                 | _ => bug "mkFctexp: unexpected access")
936          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
937          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
938          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 924  Line 941 
941    end    end
942    
943  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
944    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
945              (case access of
946                   DA.LVAR v =>
947                 let val hdr = buildHdr v                 let val hdr = buildHdr v
948                     (* binding of all v's components *)                     (* binding of all v's components *)
949                  in LET(v, mkStrexp(def, d), hdr b)                 in
950                       LET(v, mkStrexp(def, d), hdr b)
951                 end                 end
952                 | _ => bug "mkStrbs: unexpected access")
953          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
954     in fold g sbs     in fold g sbs
955    end    end
956    
957  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
958    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
959              (case access of
960                   DA.LVAR v =>
961                 let val hdr = buildHdr v                 let val hdr = buildHdr v
962                  in LET(v, mkFctexp(def, d), hdr b)                 in
963                       LET(v, mkFctexp(def, d), hdr b)
964                 end                 end
965                 | _ => bug "mkFctbs: unexpected access")
966          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
967     in fold g fbs     in fold g fbs
968    end    end
969    
# Line 1153  Line 1174 
1174  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1175    
1176  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1177  val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1178    
1179  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1180    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
# Line 1169  Line 1190 
1190  end (* structure Translate *)  end (* structure Translate *)
1191    
1192    
 (*  
  * $Log$  
  *)  

Legend:
Removed from v.251  
changed lines
  Added in v.733

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