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/kernel/ltyextern.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/kernel/ltyextern.sml

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

revision 24, Thu Mar 12 00:49:58 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 7  Line 7 
7  local structure PT = PrimTyc  local structure PT = PrimTyc
8        structure DI = DebIndex        structure DI = DebIndex
9        structure LK = LtyKernel        structure LK = LtyKernel
10          structure PO = PrimOp     (* really should not refer to this *)
11          structure FL = FLINT
12    
13        fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)        fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)
14        val say = Control.Print.say        val say = Control.Print.say
# Line 32  Line 34 
34    
35  open LtyBasic  open LtyBasic
36    
 val tc_depth = LK.tc_depth  
 val tcs_depth = LK.tcs_depth  
   
37  (** instantiating a polymorphic type or an higher-order constructor *)  (** instantiating a polymorphic type or an higher-order constructor *)
38  fun lt_inst (lt : lty, ts : tyc list) =  fun lt_inst (lt : lty, ts : tyc list) =
39    let val nt = lt_whnm lt    let val nt = lt_whnm lt
40     in (case ((* lt_outX *) lt_out nt, ts)     in (case ((* lt_outX *) lt_out nt, ts)
41          of (LK.LT_POLY(ks, b), ts) =>          of (LK.LT_POLY(ks, b), ts) =>
42               let fun h x = ltc_env(x, 1, 0, LK.tcInsert(LK.initTycEnv, (SOME ts, 0)))               let val nenv = LK.tcInsert(LK.initTycEnv, (SOME ts, 0))
43                in map h b                in map (fn x => ltc_env(x, 1, 0, nenv)) b
44               end               end
45           | (_, []) => [nt]   (* this requires further clarifications !!! *)           | (_, []) => [nt]   (* this requires further clarifications !!! *)
46           | _ => bug "incorrect lty instantiation in lt_inst")           | _ => bug "incorrect lty instantiation in lt_inst")
47    end    end
48    
49    fun lt_pinst (lt : lty, ts : tyc list) =
50      (case lt_inst (lt, ts) of [y] => y | _ => bug "unexpected lt_pinst")
51    
52  val lt_inst_st = (map lt_norm) o lt_inst   (* strict instantiation *)  val lt_inst_st = (map lt_norm) o lt_inst   (* strict instantiation *)
53    val lt_pinst_st = lt_norm o lt_pinst   (* strict instantiation *)
54    
55  exception TkTycChk  exception TkTycChk
56  exception LtyAppChk  exception LtyAppChk
# Line 57  Line 60 
60      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)
61       | _ => raise TkTycChk)       | _ => raise TkTycChk)
62    
63  fun tkApp (tk1, tk2) =  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
   (case (tk_out tk1)  
     of LK.TK_FUN(a, b) => if tk_eqv(a, tk2) then b else raise TkTycChk  
      | _ => raise TkTycChk)  
64    
65  val tkc_mono = tk_inj (LK.TK_MONO)  fun tkApp (tk, tks) =
66  val tkc_seq = tk_inj o LK.TK_SEQ    (case (tk_out tk)
67  val tkc_fun = tk_inj o LK.TK_FUN      of LK.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk
68  fun tkc_arity 0 = tkc_mono       | _ => raise TkTycChk)
   | tkc_arity n =  
       let fun h(n, r) = if n > 0 then h(n-1, tkc_mono::r)  
                         else tkc_fun(tkc_seq r, tkc_mono)  
        in h(n, [])  
       end  
69    
70  (* Warning: the following tkTyc function has not considered the  (* Warning: the following tkTyc function has not considered the
71   * occurence of .TK_BOX, in other words, if there is TK_BOX present,   * occurence of .TK_BOX, in other words, if there is TK_BOX present,
# Line 81  Line 76 
76          (case tc_out x          (case tc_out x
77            of (LK.TC_VAR (i, j)) => tkLookup(kenv, i, j)            of (LK.TC_VAR (i, j)) => tkLookup(kenv, i, j)
78             | (LK.TC_NVAR _) => bug "TC_NVAR not supported yet in tk_tyc"             | (LK.TC_NVAR _) => bug "TC_NVAR not supported yet in tk_tyc"
79             | (LK.TC_PRIM pt) => tkc_arity (PrimTyc.pt_arity pt)             | (LK.TC_PRIM pt) => tkc_int (PrimTyc.pt_arity pt)
80             | (LK.TC_FN(ks, tc)) =>             | (LK.TC_FN(ks, tc)) =>
81                 tkc_fun(tkc_seq ks, tk_tyc(tc, tkInsert(kenv, ks)))                 tkc_fun(ks, tk_tyc(tc, tkInsert(kenv, ks)))
82             | (LK.TC_APP (tc, tcs)) => tkApp(g tc, tkc_seq(map g tcs))             | (LK.TC_APP (tc, tcs)) => tkApp(g tc, map g tcs)
83             | (LK.TC_SEQ tcs) => tkc_seq (map g tcs)             | (LK.TC_SEQ tcs) => tkc_seq (map g tcs)
84             | (LK.TC_PROJ(tc, i)) => tkSel(g tc, i)             | (LK.TC_PROJ(tc, i)) => tkSel(g tc, i)
85             | (LK.TC_SUM tcs) =>             | (LK.TC_SUM tcs) =>
# Line 94  Line 89 
89             | (LK.TC_FIX ((n, tc, ts), i)) =>             | (LK.TC_FIX ((n, tc, ts), i)) =>
90                 let val k = g tc                 let val k = g tc
91                     val nk = case ts of [] => k                     val nk = case ts of [] => k
92                                       | _ => tkApp(k, tkc_seq(map g ts))                                       | _ => tkApp(k, map g ts)
93                  in (case (tk_out nk)                  in (case (tk_out nk)
94                       of LK.TK_FUN(a, b) =>                       of LK.TK_FUN(a, b) =>
95                            if tk_eqv(a, b) then tkSel(a, i)                            let val arg = case a of [x] => x
96                                                    | _ => tkc_seq a
97                               in if tk_eqv(arg, b) then
98                                    (if n = 1 then b else tkSel(arg, i))
99                            else raise TkTycChk                            else raise TkTycChk
100                              end
101                        | _ => raise TkTycChk)                        | _ => raise TkTycChk)
102                 end                 end
103             | (LK.TC_ABS tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)             | (LK.TC_ABS tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
104             | (LK.TC_BOX tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)             | (LK.TC_BOX tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
105             | (LK.TC_TUPLE tcs) =>             | (LK.TC_TUPLE (_,tcs)) =>
106                 let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs                 let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs
107                  in tkc_mono                  in tkc_mono
108                 end                 end
# Line 141  Line 140 
140    
141        val btenv = tcInsert(initTycEnv, (SOME ts, 0))        val btenv = tcInsert(initTycEnv, (SOME ts, 0))
142        val nt = h(dist, 1, bnl, btenv)        val nt = h(dist, 1, bnl, btenv)
143     in lt_norm nt     in nt (* was lt_norm nt *)
144    end    end
145    
146  (** a special tyc application --- used inside the translate/specialize.sml *)  (** a special tyc application --- used inside the translate/specialize.sml *)
# Line 154  Line 153 
153    
154        val btenv = tcInsert(initTycEnv, (SOME ts, 0))        val btenv = tcInsert(initTycEnv, (SOME ts, 0))
155        val nt = h(dist, 1, bnl, btenv)        val nt = h(dist, 1, bnl, btenv)
156     in tc_norm nt     in nt (* was tc_norm nt *)
157    end    end
158    
159  (** sinking the lty one-level down --- used inside the specialize.sml *)  (** sinking the lty one-level down --- used inside the specialize.sml *)
# Line 165  Line 164 
164                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
165               else bug "unexpected cases in ltSinkSt"               else bug "unexpected cases in ltSinkSt"
166        val nt = h(nd-d, 0, 1, initTycEnv)        val nt = h(nd-d, 0, 1, initTycEnv)
167     in lt_norm nt     in nt (* was lt_norm nt *)
168    end    end
169    
170  (** sinking the tyc one-level down --- used inside the specialize.sml *)  (** sinking the tyc one-level down --- used inside the specialize.sml *)
# Line 176  Line 175 
175                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
176               else bug "unexpected cases in ltSinkSt"               else bug "unexpected cases in ltSinkSt"
177        val nt = h(nd-d, 0, 1, initTycEnv)        val nt = h(nd-d, 0, 1, initTycEnv)
178     in tc_norm nt     in nt (* was tc_norm nt *)
179    end    end
180    
181  (** utility functions used in CPS *)  (** utility functions used in CPS *)
# Line 201  Line 200 
200  (** other misc utility functions *)  (** other misc utility functions *)
201  fun tc_select(tc, i) =  fun tc_select(tc, i) =
202    (case tc_out tc    (case tc_out tc
203      of LK.TC_TUPLE zs =>      of LK.TC_TUPLE (_,zs) =>
204           ((List.nth(zs, i)) handle _ => bug "wrong TC_TUPLE in tc_select")           ((List.nth(zs, i)) handle _ => bug "wrong TC_TUPLE in tc_select")
205       | _ => tc_bug tc "wrong TCs in tc_select")       | _ => tc_bug tc "wrong TCs in tc_select")
206    
# Line 219  Line 218 
218    
219  fun tc_swap t =  fun tc_swap t =
220    (case (tc_out t)    (case (tc_out t)
221      of LK.TC_ARROW ((r1,r2), [s1], [s2]) => tcc_arrow((r2,r1), [s2], [s1])      of LK.TC_ARROW (LK.FF_VAR (r1,r2), [s1], [s2]) =>
222             tcc_arrow(LK.FF_VAR (r2,r1), [s2], [s1])
223         | LK.TC_ARROW (LK.FF_FIXED, [s1], [s2]) =>
224             tcc_arrow(LK.FF_FIXED, [s2], [s1])
225       | _ => bug "unexpected tycs in tc_swap")       | _ => bug "unexpected tycs in tc_swap")
226    
227  fun lt_swap t =  fun lt_swap t =
# Line 228  Line 230 
230       | (LK.LT_TYC x) => ltc_tyc(tc_swap x)       | (LK.LT_TYC x) => ltc_tyc(tc_swap x)
231       | _ => bug "unexpected type in lt_swap")       | _ => bug "unexpected type in lt_swap")
232    
233    (** functions that manipulate the FLINT function and record types *)
234    fun ltc_fkfun (FL.FK_FCT, atys, rtys) =
235          ltc_fct (atys, rtys)
236      | ltc_fkfun (FL.FK_FUN {fixed, ...}, atys, rtys) =
237          ltc_arrow(fixed, atys, rtys)
238    
239    fun ltd_fkfun lty =
240      if ltp_fct lty then ltd_fct lty
241      else let val (_, atys, rtys) = ltd_arrow lty
242            in (atys, rtys)
243           end
244    
245    fun ltc_rkind (FL.RK_TUPLE _, lts) = ltc_tuple lts
246      | ltc_rkind (FL.RK_STRUCT, lts) = ltc_str lts
247      | ltc_rkind (FL.RK_VECTOR t, _) = ltc_vector (ltc_tyc t)
248    
249    fun ltd_rkind (lt, i) = lt_select (lt, i)
250    
251    (****************************************************************************
252     *        THE FOLLOWING UTILITY FUNCTIONS WILL SOON BE OBSOLETE             *
253     ****************************************************************************)
254    
255  (** a version of ltc_arrow with singleton argument and return result *)  (** a version of ltc_arrow with singleton argument and return result *)
256  val ltc_arw = ltc_parrow  val ltc_arw = ltc_parrow
257    
# Line 258  Line 282 
282                in (s1, s2)                in (s1, s2)
283               end))               end))
284    
285    
286    
287    (****************************************************************************
288     *             UTILITY FUNCTIONS USED BY POST-REPRESENTATION ANALYSIS       *
289     ****************************************************************************)
290    (** find out what is the appropriate primop given a tyc *)
291    fun tc_upd_prim tc =
292      let fun h(LK.TC_PRIM pt) =
293                if PT.ubxupd pt then PO.UNBOXEDUPDATE
294                else if PT.bxupd pt then PO.BOXEDUPDATE
295                     else PO.UPDATE
296            | h(LK.TC_TUPLE _ | LK.TC_ARROW _) = PO.BOXEDUPDATE
297            | h(LK.TC_FIX ((1,tc,ts), 0)) =
298                let val ntc = case ts of [] => tc
299                                       | _ => tcc_app(tc, ts)
300                 in (case (tc_out ntc)
301                      of LK.TC_FN([k],b) => h (tc_out b)
302                       | _ => PO.UPDATE)
303                end
304            | h(LK.TC_SUM tcs) =
305                let fun g (a::r) = if tc_eqv(a, tcc_unit) then g r else false
306                      | g [] = true
307                 in if (g tcs) then PO.UNBOXEDUPDATE else PO.UPDATE
308                end
309            | h _ = PO.UPDATE
310       in h(tc_out tc)
311      end
312    
313    (** tk_lty : tkind -> lty --- finds out the corresponding type for a tkind *)
314    fun tk_lty tk =
315      (case tk_out tk
316        of LK.TK_MONO => ltc_int
317         | LK.TK_BOX => ltc_int
318         | LK.TK_SEQ ks => ltc_tuple (map tk_lty ks)
319         | LK.TK_FUN (ks, k) => ltc_parrow(ltc_tuple(map tk_lty ks), tk_lty k))
320    
321    
322    (* val tnarrow_gen : unit -> ((tyc -> tyc) * (lty -> lty) * (unit->unit)) *)
323    fun tnarrow_gen () =
324      let fun tcNarrow tcf t =
325            (case (tc_out t)
326              of LK.TC_PRIM pt =>
327                   if PT.isvoid pt then tcc_void else t
328               | LK.TC_TUPLE (_, tcs) => tcc_tuple (map tcf tcs)
329               | LK.TC_ARROW (r, ts1, ts2) =>
330                   tcc_arrow(r, map tcf ts1, map tcf ts2)
331               | _ => tcc_void)
332    
333          fun ltNarrow (tcf, ltf) t =
334            (case lt_out t
335              of LK.LT_TYC tc => ltc_tyc (tcf tc)
336               | LK.LT_STR ts => ltc_str (map ltf ts)
337               | LK.LT_PST its => ltc_pst (map (fn (i, t) => (i, ltf t)) its)
338               | LK.LT_FCT (ts1, ts2) => ltc_fct(map ltf ts1, map ltf ts2)
339               | LK.LT_POLY (ks, xs) =>
340                   ltc_fct([ltc_str (map tk_lty ks)], map ltf xs)
341               | LK.LT_CONT _ => bug "unexpected CNTs in ltNarrow"
342               | LK.LT_IND _ => bug "unexpected INDs in ltNarrow"
343               | LK.LT_ENV _ => bug "unexpected ENVs in ltNarrow")
344    
345          val {tc_map, lt_map} = LtyDict.tmemo_gen {tcf=tcNarrow, ltf=ltNarrow}
346       in (tc_map, lt_map, fn ()=>())
347      end (* function tnarrow_gen *)
348    
349  end (* top-level local *)  end (* top-level local *)
350  end (* structure LtyExtern *)  end (* structure LtyExtern *)
351    

Legend:
Removed from v.24  
changed lines
  Added in v.45

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