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 17, Wed Mar 11 21:00:18 1998 UTC revision 24, Thu Mar 12 00:49:58 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
       structure PO = PrimOp     (* really should not refer to this *)  
       structure FL = FLINT  
10    
11        fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)        fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)
12        val say = Control.Print.say        val say = Control.Print.say
# Line 42  Line 40 
40    let val nt = lt_whnm lt    let val nt = lt_whnm lt
41     in (case ((* lt_outX *) lt_out nt, ts)     in (case ((* lt_outX *) lt_out nt, ts)
42          of (LK.LT_POLY(ks, b), ts) =>          of (LK.LT_POLY(ks, b), ts) =>
43               let val nenv = LK.tcInsert(LK.initTycEnv, (SOME ts, 0))               let fun h x = ltc_env(x, 1, 0, LK.tcInsert(LK.initTycEnv, (SOME ts, 0)))
44                in map (fn x => ltc_env(x, 1, 0, nenv)) b                in map h b
45               end               end
46           | (_, []) => [nt]   (* this requires further clarifications !!! *)           | (_, []) => [nt]   (* this requires further clarifications !!! *)
47           | _ => bug "incorrect lty instantiation in lt_inst")           | _ => bug "incorrect lty instantiation in lt_inst")
48    end    end
49    
 fun lt_pinst (lt : lty, ts : tyc list) =  
   (case lt_inst (lt, ts) of [y] => y | _ => bug "unexpected lt_pinst")  
   
50  val lt_inst_st = (map lt_norm) o lt_inst   (* strict instantiation *)  val lt_inst_st = (map lt_norm) o lt_inst   (* strict instantiation *)
 val lt_pinst_st = lt_norm o lt_pinst   (* strict instantiation *)  
51    
52  exception TkTycChk  exception TkTycChk
53  exception LtyAppChk  exception LtyAppChk
# Line 63  Line 57 
57      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)      of (LK.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)
58       | _ => raise TkTycChk)       | _ => raise TkTycChk)
59    
60  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)  fun tkApp (tk1, tk2) =
61      (case (tk_out tk1)
62  fun tkApp (tk, tks) =      of LK.TK_FUN(a, b) => if tk_eqv(a, tk2) then b else raise TkTycChk
   (case (tk_out tk)  
     of LK.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk  
63       | _ => raise TkTycChk)       | _ => raise TkTycChk)
64    
65    val tkc_mono = tk_inj (LK.TK_MONO)
66    val tkc_seq = tk_inj o LK.TK_SEQ
67    val tkc_fun = tk_inj o LK.TK_FUN
68    fun tkc_arity 0 = tkc_mono
69      | tkc_arity n =
70          let fun h(n, r) = if n > 0 then h(n-1, tkc_mono::r)
71                            else tkc_fun(tkc_seq r, tkc_mono)
72           in h(n, [])
73          end
74    
75  (* Warning: the following tkTyc function has not considered the  (* Warning: the following tkTyc function has not considered the
76   * 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,
77   * then the tk_tyc checker will produce wrong results. (ZHONG)   * then the tk_tyc checker will produce wrong results. (ZHONG)
# Line 79  Line 81 
81          (case tc_out x          (case tc_out x
82            of (LK.TC_VAR (i, j)) => tkLookup(kenv, i, j)            of (LK.TC_VAR (i, j)) => tkLookup(kenv, i, j)
83             | (LK.TC_NVAR _) => bug "TC_NVAR not supported yet in tk_tyc"             | (LK.TC_NVAR _) => bug "TC_NVAR not supported yet in tk_tyc"
84             | (LK.TC_PRIM pt) => tkc_int (PrimTyc.pt_arity pt)             | (LK.TC_PRIM pt) => tkc_arity (PrimTyc.pt_arity pt)
85             | (LK.TC_FN(ks, tc)) =>             | (LK.TC_FN(ks, tc)) =>
86                 tkc_fun(ks, tk_tyc(tc, tkInsert(kenv, ks)))                 tkc_fun(tkc_seq ks, tk_tyc(tc, tkInsert(kenv, ks)))
87             | (LK.TC_APP (tc, tcs)) => tkApp(g tc, map g tcs)             | (LK.TC_APP (tc, tcs)) => tkApp(g tc, tkc_seq(map g tcs))
88             | (LK.TC_SEQ tcs) => tkc_seq (map g tcs)             | (LK.TC_SEQ tcs) => tkc_seq (map g tcs)
89             | (LK.TC_PROJ(tc, i)) => tkSel(g tc, i)             | (LK.TC_PROJ(tc, i)) => tkSel(g tc, i)
90             | (LK.TC_SUM tcs) =>             | (LK.TC_SUM tcs) =>
# Line 92  Line 94 
94             | (LK.TC_FIX ((n, tc, ts), i)) =>             | (LK.TC_FIX ((n, tc, ts), i)) =>
95                 let val k = g tc                 let val k = g tc
96                     val nk = case ts of [] => k                     val nk = case ts of [] => k
97                                       | _ => tkApp(k, map g ts)                                       | _ => tkApp(k, tkc_seq(map g ts))
98                  in (case (tk_out nk)                  in (case (tk_out nk)
99                       of LK.TK_FUN(a, b) =>                       of LK.TK_FUN(a, b) =>
100                            let val arg = case a of [x] => x                            if tk_eqv(a, b) then tkSel(a, i)
                                                 | _ => tkc_seq a  
                            in if tk_eqv(arg, b) then  
                                 (if n = 1 then b else tkSel(arg, i))  
101                                else raise TkTycChk                                else raise TkTycChk
                           end  
102                        | _ => raise TkTycChk)                        | _ => raise TkTycChk)
103                 end                 end
104             | (LK.TC_ABS tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)             | (LK.TC_ABS tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
105             | (LK.TC_BOX tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)             | (LK.TC_BOX tc) => (tk_eqv(g tc, tkc_mono); tkc_mono)
106             | (LK.TC_TUPLE (_,tcs)) =>             | (LK.TC_TUPLE tcs) =>
107                 let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs                 let val _ = map (fn x => tk_eqv(g x, tkc_mono)) tcs
108                  in tkc_mono                  in tkc_mono
109                 end                 end
# Line 143  Line 141 
141    
142        val btenv = tcInsert(initTycEnv, (SOME ts, 0))        val btenv = tcInsert(initTycEnv, (SOME ts, 0))
143        val nt = h(dist, 1, bnl, btenv)        val nt = h(dist, 1, bnl, btenv)
144     in nt (* was lt_norm nt *)     in lt_norm nt
145    end    end
146    
147  (** a special tyc application --- used inside the translate/specialize.sml *)  (** a special tyc application --- used inside the translate/specialize.sml *)
# Line 156  Line 154 
154    
155        val btenv = tcInsert(initTycEnv, (SOME ts, 0))        val btenv = tcInsert(initTycEnv, (SOME ts, 0))
156        val nt = h(dist, 1, bnl, btenv)        val nt = h(dist, 1, bnl, btenv)
157     in nt (* was tc_norm nt *)     in tc_norm nt
158    end    end
159    
160  (** sinking the lty one-level down --- used inside the specialize.sml *)  (** sinking the lty one-level down --- used inside the specialize.sml *)
# Line 167  Line 165 
165                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
166               else bug "unexpected cases in ltSinkSt"               else bug "unexpected cases in ltSinkSt"
167        val nt = h(nd-d, 0, 1, initTycEnv)        val nt = h(nd-d, 0, 1, initTycEnv)
168     in nt (* was lt_norm nt *)     in lt_norm nt
169    end    end
170    
171  (** sinking the tyc one-level down --- used inside the specialize.sml *)  (** sinking the tyc one-level down --- used inside the specialize.sml *)
# Line 178  Line 176 
176                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))                 h(abslevel-1, ol+1, nl+1, tcInsert(tenv, (NONE, nl)))
177               else bug "unexpected cases in ltSinkSt"               else bug "unexpected cases in ltSinkSt"
178        val nt = h(nd-d, 0, 1, initTycEnv)        val nt = h(nd-d, 0, 1, initTycEnv)
179     in nt (* was tc_norm nt *)     in tc_norm nt
180    end    end
181    
182  (** utility functions used in CPS *)  (** utility functions used in CPS *)
# Line 203  Line 201 
201  (** other misc utility functions *)  (** other misc utility functions *)
202  fun tc_select(tc, i) =  fun tc_select(tc, i) =
203    (case tc_out tc    (case tc_out tc
204      of LK.TC_TUPLE (_,zs) =>      of LK.TC_TUPLE zs =>
205           ((List.nth(zs, i)) handle _ => bug "wrong TC_TUPLE in tc_select")           ((List.nth(zs, i)) handle _ => bug "wrong TC_TUPLE in tc_select")
206       | _ => tc_bug tc "wrong TCs in tc_select")       | _ => tc_bug tc "wrong TCs in tc_select")
207    
# Line 230  Line 228 
228       | (LK.LT_TYC x) => ltc_tyc(tc_swap x)       | (LK.LT_TYC x) => ltc_tyc(tc_swap x)
229       | _ => bug "unexpected type in lt_swap")       | _ => bug "unexpected type in lt_swap")
230    
 (** functions that manipulate the FLINT function and record types *)  
 fun ltc_fkfun (FL.FK_FCT, atys, rtys) =  
       ltc_fct (atys, rtys)  
   | ltc_fkfun (FL.FK_FUN {fixed, ...}, atys, rtys) =  
       ltc_arrow(fixed, atys, rtys)  
   
 fun ltd_fkfun lty =  
   if ltp_fct lty then ltd_fct lty  
   else let val (_, atys, rtys) = ltd_arrow lty  
         in (atys, rtys)  
        end  
   
 fun ltc_rkind (FL.RK_TUPLE _, lts) = ltc_tuple lts  
   | ltc_rkind (FL.RK_STRUCT, lts) = ltc_str lts  
   | ltc_rkind (FL.RK_VECTOR t, _) = ltc_vector (ltc_tyc t)  
   
 fun ltd_rkind (lt, i) = lt_select (lt, i)  
   
231  (** a version of ltc_arrow with singleton argument and return result *)  (** a version of ltc_arrow with singleton argument and return result *)
232  val ltc_arw = ltc_parrow  val ltc_arw = ltc_parrow
233    
# Line 278  Line 258 
258                in (s1, s2)                in (s1, s2)
259               end))               end))
260    
 fun tc_upd_prim tc =  
   let fun h(LK.TC_PRIM pt) =  
             if PT.ubxupd pt then PO.UNBOXEDUPDATE  
             else if PT.bxupd pt then PO.BOXEDUPDATE  
                  else PO.UPDATE  
         | h(LK.TC_TUPLE _ | LK.TC_ARROW _) = PO.BOXEDUPDATE  
         | h(LK.TC_FIX ((1,tc,ts), 0)) =  
             let val ntc = case ts of [] => tc  
                                    | _ => tcc_app(tc, ts)  
              in (case (tc_out ntc)  
                   of LK.TC_FN([k],b) => h (tc_out b)  
                    | _ => PO.UPDATE)  
             end  
         | h(LK.TC_SUM tcs) =  
             let fun g (a::r) = if tc_eqv(a, tcc_unit) then g r else false  
                   | g [] = true  
              in if (g tcs) then PO.UNBOXEDUPDATE else PO.UPDATE  
             end  
         | h _ = PO.UPDATE  
    in h(tc_out tc)  
   end  
   
   
261  end (* top-level local *)  end (* top-level local *)
262  end (* structure LtyExtern *)  end (* structure LtyExtern *)
263    

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

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