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/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/trans/translate.sml

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

revision 122, Sat Jun 6 15:05:38 1998 UTC revision 773, Mon Jan 8 16:18:37 2001 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 684  Line 697 
697                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
698                end                end
699    
700    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
701          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
702                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
703                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 699  Line 713 
713                 in FN(x, argt,                 in FN(x, argt,
714                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
715                end                end
716    ****)
717    
718          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
719    
# Line 721  Line 736 
736        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
737    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
738    
739  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, typ), ...}, ts, d) =
740        (case (p, ts)        (case (p, ts)
741          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
742           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
# Line 731  Line 746 
746                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
747                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
748                  end                  end
749             | (PO.RAW_CCALL NONE, [a, b, c]) =>
750               let val i = SOME { c_proto = CProto.decode b,
751                                  ml_flt_args = CProto.flt_args a,
752                                  ml_flt_res = CProto.flt_res c }
753                       handle CProto.BadEncoding => NONE
754                in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
755               end
756           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))
   
   | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =  
       (case ts of [] => transPrim(p, (toLty d (!typ)), [])  
                 | [x] =>  
                    (* a temporary hack to resolve the boot/built-in.sml file *)  
                    (let val lt = toLty d (!typ)  
                         val nt = toLty d x  
                      in if LT.lt_eqv(LT.ltc_top, lt)  
                         then transPrim(p, nt, [])  
                         else bug "unexpected primop in mkVE"  
                     end)  
                 | _ => bug "unexpected poly primops in mkVE")  
   
757    | mkVE (v, [], d) = mkVar(v, d)    | mkVE (v, [], d) = mkVar(v, d)
758    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)
759    
# Line 906  Line 915 
915    
916  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
917    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
918          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
919              (case access of
920                   DA.LVAR v =>
921                let val knds = map tpsKnd argtycs                let val knds = map tpsKnd argtycs
922                    val nd = DI.next d                    val nd = DI.next d
923                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
924                    val hdr = buildHdr v                    val hdr = buildHdr v
925                    (* binding of all v's components *)                    (* binding of all v's components *)
926                 in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))                 in
927                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
928                end                end
929                 | _ => bug "mkFctexp: unexpected access")
930          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
931          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
932          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 922  Line 935 
935    end    end
936    
937  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
938    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
939              (case access of
940                   DA.LVAR v =>
941                 let val hdr = buildHdr v                 let val hdr = buildHdr v
942                     (* binding of all v's components *)                     (* binding of all v's components *)
943                  in LET(v, mkStrexp(def, d), hdr b)                 in
944                       LET(v, mkStrexp(def, d), hdr b)
945                 end                 end
946                 | _ => bug "mkStrbs: unexpected access")
947          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
948     in fold g sbs     in fold g sbs
949    end    end
950    
951  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
952    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
953              (case access of
954                   DA.LVAR v =>
955                 let val hdr = buildHdr v                 let val hdr = buildHdr v
956                  in LET(v, mkFctexp(def, d), hdr b)                 in
957                       LET(v, mkFctexp(def, d), hdr b)
958                 end                 end
959                 | _ => bug "mkFctbs: unexpected access")
960          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
961     in fold g fbs     in fold g fbs
962    end    end
963    
# Line 1151  Line 1168 
1168  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1169    
1170  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1171  val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1172    
1173  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1174    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 1167  Line 1184 
1184  end (* structure Translate *)  end (* structure Translate *)
1185    
1186    
 (*  
  * $Log$  
  *)  

Legend:
Removed from v.122  
changed lines
  Added in v.773

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