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

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

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

revision 23, Thu Mar 12 00:49:56 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 44  Line 44 
44    = TK_MONO                                    (* ground mono tycon *)    = TK_MONO                                    (* ground mono tycon *)
45    | TK_BOX                                     (* boxed/tagged tycon *)    | TK_BOX                                     (* boxed/tagged tycon *)
46    | TK_SEQ of tkind list                       (* sequence of tycons *)    | TK_SEQ of tkind list                       (* sequence of tycons *)
47    | TK_FUN of tkind list * tkind               (* tycon function *)    | TK_FUN of tkind * tkind                    (* tycon function *)
48    
49  withtype tkind = tkindI hash_cell              (* hash-consing-impl of tkind *)  withtype tkind = tkindI hash_cell              (* hash-consing-impl of tkind *)
50    
# Line 52  Line 52 
52  type tvar = LambdaVar.lvar                     (* temporary definitions *)  type tvar = LambdaVar.lvar                     (* temporary definitions *)
53  val mkTvar = LambdaVar.mkLvar  val mkTvar = LambdaVar.mkLvar
54    
55  (** definitions of lambda type constructors *)  (** definitions of lambda tycons and lambda types *)
56  datatype tycI  datatype tycI
57    = TC_VAR of DebIndex.index * int             (* tyc variables *)    = TC_VAR of DebIndex.index * int             (* tyc variables *)
58    | TC_NVAR of tvar * DebIndex.depth * int     (* named tyc variables *)    | TC_NVAR of tvar * DebIndex.depth * int     (* named tyc variables *)
# Line 66  Line 66 
66    | TC_SUM of tyc list                         (* sum tyc *)    | TC_SUM of tyc list                         (* sum tyc *)
67    | TC_FIX of (int * tyc * tyc list) * int     (* recursive tyc *)    | TC_FIX of (int * tyc * tyc list) * int     (* recursive tyc *)
68    
69    | TC_TUPLE of rflag * tyc list               (* std record tyc *)    | TC_TUPLE of tyc list                       (* std record tyc *)
70    | TC_ARROW of fflag * tyc list * tyc list    (* std function tyc *)    | TC_ARROW of rawflag * tyc list * tyc list  (* std function tyc *)
71    | TC_PARROW of tyc * tyc                     (* special fun tyc, not used *)    | TC_PARROW of tyc * tyc                     (* special fun tyc, not used *)
72    
73    | TC_BOX of tyc                              (* boxed tyc *)    | TC_BOX of tyc                              (* boxed tyc *)
# Line 76  Line 76 
76    | TC_IND of tyc * tycI                       (* indirect tyc thunk *)    | TC_IND of tyc * tycI                       (* indirect tyc thunk *)
77    | TC_ENV of tyc * int * int * tycEnv         (* tyc closure *)    | TC_ENV of tyc * int * int * tycEnv         (* tyc closure *)
78    
79  withtype tyc = tycI hash_cell                  (* hash-consed tyc cell *)  and ltyI
      and tycEnv = tyc     (*  
                            * This really is (tyc list option * int) list,  
                            * it is encoded using SEQ[(PROJ(SEQ tcs),i)]  
                            * and SEQ[(PROJ(VOID, i))]. (ZHONG)  
                            *)  
   
      and fflag = bool * bool (* is the calling convention fixed ? *)  
      and rflag = unit     (* record kind, not used as of now *)  
   
 val default_rflag = ()    (* a rflag template *)  
 val default_fflag = (true,true)  
   
 (** definitions of lambda types *)  
 datatype ltyI  
80    = LT_TYC of tyc                              (* monomorphic type *)    = LT_TYC of tyc                              (* monomorphic type *)
81    | LT_STR of lty list                         (* structure record type *)    | LT_STR of lty list                         (* structure record type *)
82    | LT_FCT of lty list * lty list              (* functor arrow type *)    | LT_FCT of lty list * lty list              (* functor arrow type *)
# Line 101  Line 87 
87    | LT_IND of lty * ltyI                       (* a lty thunk and its sig *)    | LT_IND of lty * ltyI                       (* a lty thunk and its sig *)
88    | LT_ENV of lty * int * int * tycEnv         (* lty closure *)    | LT_ENV of lty * int * int * tycEnv         (* lty closure *)
89    
90  withtype lty = ltyI hash_cell                  (* hash-consed lty cell *)  withtype tyc = tycI hash_cell                  (* hash-consed tyc cell *)
91    
92         and lty = ltyI hash_cell                  (* hash-consed lty cell *)
93    
94         and tycEnv = tyc     (*
95                               * This really is (tyc list option * int) list,
96                               * it is encoded using SEQ[(PROJ(SEQ tcs),i)]
97                               * and SEQ[(PROJ(VOID, i))]. (ZHONG)
98                               *)
99    
100         and rawflag = bool * bool (* are arguments/results raw or cooked ? *)
101    
102    
103  (***************************************************************************  (***************************************************************************
104   *                   HASHCONSING IMPLEMENTATIONS                           *   *                   HASHCONSING IMPLEMENTATIONS                           *
# Line 185  Line 182 
182          let fun g (TK_MONO) = 0w1          let fun g (TK_MONO) = 0w1
183                | g (TK_BOX) = 0w2                | g (TK_BOX) = 0w2
184                | g (TK_SEQ ks) = combine (3::map getnum ks)                | g (TK_SEQ ks) = combine (3::map getnum ks)
185                | g (TK_FUN(ks, k)) = combine (4::getnum k::(map getnum ks))                | g (TK_FUN(k1, k2)) = combine [4, getnum k1, getnum k2]
186           in g tk           in g tk
187          end          end
188    
# Line 202  Line 199 
199                       combine (8::n::i::(getnum t)::(map getnum ts))                       combine (8::n::i::(getnum t)::(map getnum ts))
200                | g (TC_ABS t) = combine [9, getnum t]                | g (TC_ABS t) = combine [9, getnum t]
201                | g (TC_BOX t) = combine [10, getnum t]                | g (TC_BOX t) = combine [10, getnum t]
202                | g (TC_TUPLE (_, ts)) = combine (11::(map getnum ts))                | g (TC_TUPLE ts) = combine (11::(map getnum ts))
203                | g (TC_ARROW(rw, ts1, ts2)) =                | g (TC_ARROW(rw, ts1, ts2)) =
204                       let fun h(true, true) = 10                       let fun h(true, true) = 10
205                             | h(true, _) = 20                             | h(true, _) = 20
# Line 266  Line 263 
263    
264        fun tc_aux tc =        fun tc_aux tc =
265          let fun g (TC_VAR(d, i)) = AX_REG(true, [tvToInt(d, i)])          let fun g (TC_VAR(d, i)) = AX_REG(true, [tvToInt(d, i)])
266                | g (TC_NVAR(v, d, i)) = baseAux (*** THIS IS WRONG ! ***)                | g (TC_NVAR(v, d, i)) = baseAux (*** incorrect ? ***)
267                | g (TC_PRIM pt) = baseAux                | g (TC_PRIM pt) = baseAux
268                | g (TC_APP(ref(_, TC_FN _, AX_NO), _)) = AX_NO                | g (TC_APP(ref(_, TC_FN _, AX_NO), _)) = AX_NO
269                | g (TC_PROJ(ref(_, TC_SEQ _, AX_NO), _)) = AX_NO                | g (TC_PROJ(ref(_, TC_SEQ _, AX_NO), _)) = AX_NO
# Line 287  Line 284 
284                       end                       end
285                | g (TC_ABS t) = getAux t                | g (TC_ABS t) = getAux t
286                | g (TC_BOX t) = getAux t                | g (TC_BOX t) = getAux t
287                | g (TC_TUPLE (_, ts)) = fsmerge ts                | g (TC_TUPLE ts) = fsmerge ts
288                | g (TC_ARROW(_, ts1, ts2)) = fsmerge (ts1@ts2)                | g (TC_ARROW(_, ts1, ts2)) = fsmerge (ts1@ts2)
289                | g (TC_PARROW(t1, t2)) = fsmerge [t1, t2]                | g (TC_PARROW(t1, t2)) = fsmerge [t1, t2]
290                | g (TC_CONT ts) = fsmerge ts                | g (TC_CONT ts) = fsmerge ts
# Line 395  Line 392 
392    | ltp_norm _ = false    | ltp_norm _ = false
393    
394    
395    (** finding out the innermost binding depth for a tyc's free variables *)
396    fun tc_depth (x, d) =
397      let val tvs = tc_vs x
398       in case tvs
399           of NONE => bug "unexpected case in tc_depth"
400            | SOME [] => DI.top
401            | SOME (a::_) => d + 1 - (#1(tvFromInt a))
402      end
403    
404    fun tcs_depth ([], d) = DI.top
405      | tcs_depth (x::r, d) = Int.max(tc_depth(x, d), tcs_depth(r, d))
406    
407  (** utility functions for tc_env and lt_env *)  (** utility functions for tc_env and lt_env *)
408  local fun tcc_env_int(x, 0, 0, te) = x  local fun tcc_env_int(x, 0, 0, te) = x
409          | tcc_env_int(x, i, j, te) = tc_injX(TC_ENV(x, i, j, te))          | tcc_env_int(x, i, j, te) = tc_injX(TC_ENV(x, i, j, te))
# Line 467  Line 476 
476  val tcc_app = tc_injX o TC_APP  val tcc_app = tc_injX o TC_APP
477  val tcc_seq = tc_injX o TC_SEQ  val tcc_seq = tc_injX o TC_SEQ
478  val tcc_proj = tc_injX o TC_PROJ  val tcc_proj = tc_injX o TC_PROJ
479    val tcc_sum = tc_injX o TC_SUM
480  val tcc_fix = tc_injX o TC_FIX  val tcc_fix = tc_injX o TC_FIX
481  val tcc_abs = tc_injX o TC_ABS  val tcc_abs = tc_injX o TC_ABS
482    val tcc_box = tc_injX o TC_BOX
483  val tcc_tup  = tc_injX o TC_TUPLE  val tcc_tup  = tc_injX o TC_TUPLE
484  val tcc_parw = tc_injX o TC_PARROW  val tcc_parw = tc_injX o TC_PARROW
485  val ltc_tyc = lt_injX o LT_TYC  val ltc_tyc = lt_injX o LT_TYC
# Line 476  Line 487 
487  val ltc_pst = lt_injX o LT_PST  val ltc_pst = lt_injX o LT_PST
488  val ltc_fct = lt_injX o LT_FCT  val ltc_fct = lt_injX o LT_FCT
489  val ltc_poly = lt_injX o LT_POLY  val ltc_poly = lt_injX o LT_POLY
 val tcc_sum = tc_injX o TC_SUM  
490    
491  (** the following function contains the procedure on how to  (** the following function contains the procedure on how to
492      flatten the arguments and results of an arbitrary FLINT function      flatten the arguments and results of an arbitrary FLINT function
# Line 492  Line 502 
502  and tc_autoflat tc =  and tc_autoflat tc =
503    let val ntc = tc_whnm tc    let val ntc = tc_whnm tc
504     in (case tc_outX ntc     in (case tc_outX ntc
505          of TC_TUPLE (_, [_]) => (* singleton record is not flattened to ensure          of TC_TUPLE [_] => (* singleton record is not flattened to ensure
506                                isomorphism btw plambdatype and flinttype *)                                isomorphism btw plambdatype and flinttype *)
507               (true, [ntc], false)               (true, [ntc], false)
508           | TC_TUPLE (_, ts) =>           | TC_TUPLE ts => (true, ts, true)
              if length ts < 10 then (true, ts, true)  
              else (true, [ntc], false)  (* ZHONG added the magic number 10 *)  
509           | _ => if isKnown ntc then (true, [ntc], false)           | _ => if isKnown ntc then (true, [ntc], false)
510                  else (false, [ntc], false))                  else (false, [ntc], false))
511    end    end
512    
513  and tc_autotuple [x] = x  and tc_autotuple [x] = x
514    | tc_autotuple xs =    | tc_autotuple xs = tcc_tup xs
        if length xs < 10 then tcc_tup (default_rflag, xs)  
        else bug "fatal error with tc_autotuple"  
515    
516  and tcs_autoflat (flag, ts) =  and tcs_autoflat (flag, ts) =
517    if flag then (flag, ts)    if flag then (flag, ts)
# Line 531  Line 537 
537         in tc_injX (TC_ARROW((nb1, nb2),  nts1, nts2))         in tc_injX (TC_ARROW((nb1, nb2),  nts1, nts2))
538        end        end
539    
 (** tcc_wrap applies to tyc of all kinds *)  
 and tcc_wrap t =  
   let val nt = tc_whnm t  
    in (case tc_outX nt  (* follow the kind relationship *)  
         of TC_SEQ ts => tcc_seq (map tcc_wrap ts)  
          | TC_FN(ks, tc) =>  tcc_fn(ks, tcc_wrap tc)  
          | TC_APP(t, ts) => tcc_app(tcc_wrap t, map tcc_wrap ts)  
          | (TC_PROJ _ | TC_VAR _ | TC_NVAR _) => nt  
          | TC_PRIM pt => if PT.pt_arity pt > 0 then nt else tcc_box nt  
          | _ => tcc_box nt)  
   end (* function tc_wrap *)  
   
 (** tcc_box only applies to tyc of kind tkc_mono *)  
 and tcc_box t =  
   let val nt = tcc_uncv t (* must produce a whnm *)  
    in (case tc_outX nt  
         of (TC_VAR _ | TC_NVAR _ | TC_APP _ | TC_PROJ _) => nt  
          | (TC_FIX _ | TC_SUM _) => nt  (* simplification here *)  
          | TC_PRIM pt => if PT.unboxed pt then tc_injX(TC_BOX nt) else nt  
          | (TC_TUPLE _ | TC_ARROW _) => tc_injX(TC_BOX nt)  
          | TC_BOX _ => bug "unexpected TC_BOX in tcc_box"  
          | (TC_SEQ _ | TC_FN _) => bug "unexpected tyc (SEQ/FN) in tcc_box"  
          | _ => bug "unsupported tycs in tcc_box")  
   end  
   
 (** tcc_uncv is to recursively box a tyc of kind tkc_mono *)  
 and tcc_uncv t =  
   let val nt = tc_whnm t  
    in (case tc_outX nt  
         of (TC_VAR _ | TC_NVAR _ | TC_APP _ | TC_PROJ _) => nt  
          | (TC_FIX _ | TC_SUM _ | TC_PRIM _) => nt  (* simplified here *)  
          | (TC_SEQ _ | TC_FN _) => bug "unexpected tyc (SEQ/FN) in tcc_box"  
          | TC_BOX x => x  
          | TC_TUPLE (rk, ts) => tcc_tup(rk, map tcc_uncv ts)  
 (*  
          | TC_ARROW ((b1,b2), ts1, ts2) =>  
              let val nts1 = map tcc_uncv ts1  
                  val nts2 = map tcc_uncv ts2  
                  val nts1 =  
                    case (b1, ts1)  
                     of (_, [t11, t12]) => [tcc_box t11, tcc_box t12]  
                      | (true, _) => tcc_box(tc_autotuple ts1)  
                      | _ => bug "not implemented"  
   
 *)  
          | TC_ARROW ((true,b2), [t11,t12], ts2) =>  
              let val nt11 = tcc_box t11  
                  val nt12 = tcc_box t12  
                  val t2 = tcc_box(tc_autotuple ts2)  
                  (* after boxing, all calling conventions are fixed ! *)  
               in tcc_arw((true,true),[nt11,nt12],[t2])  
              end  
          | TC_ARROW ((b1,b2), ts1, ts2) =>  
              let val t1 = tcc_box(tc_autotuple ts1)  
                  val t2 = tcc_box(tc_autotuple ts2)  
                  (* after boxing, all calling conventions are fixed ! *)  
               in tcc_arw((true,true),[t1],[t2])  
              end  
          | _ => bug "unsupported tycs in tcc_box")  
   end  
   
540  (** utility function to read the top-level of a tyc *)  (** utility function to read the top-level of a tyc *)
541  and tc_lzrd t =  and tc_lzrd t =
542    let fun g x =    let fun g x =
# Line 633  Line 578 
578                          tcc_fix((n, prop tc, map prop ts), i)                          tcc_fix((n, prop tc, map prop ts), i)
579                     | TC_ABS tc => tcc_abs (prop tc)                     | TC_ABS tc => tcc_abs (prop tc)
580                     | TC_BOX tc => tcc_box (prop tc)                     | TC_BOX tc => tcc_box (prop tc)
581                     | TC_TUPLE (rk, tcs) => tcc_tup (rk, map prop tcs)                     | TC_TUPLE tcs => tcc_tup (map prop tcs)
582                     | TC_ARROW (r, ts1, ts2) =>                     | TC_ARROW (r, ts1, ts2) =>
583                         tcc_arw (r, map prop ts1, map prop ts2)                         tcc_arw (r, map prop ts1, map prop ts2)
584                     | TC_PARROW (t1, t2) => tcc_parw (prop t1, prop t2)                     | TC_PARROW (t1, t2) => tcc_parw (prop t1, prop t2)
# Line 770  Line 715 
715                       tcc_fix((n, tc_norm tc, map tc_norm ts), i)                       tcc_fix((n, tc_norm tc, map tc_norm ts), i)
716                   | TC_ABS tc => tcc_abs(tc_norm tc)                   | TC_ABS tc => tcc_abs(tc_norm tc)
717                   | TC_BOX tc => tcc_box(tc_norm tc)                   | TC_BOX tc => tcc_box(tc_norm tc)
718                   | TC_TUPLE (rk, tcs) => tcc_tup(rk, map tc_norm tcs)                   | TC_TUPLE tcs => tcc_tup(map tc_norm tcs)
719                   | TC_ARROW (r, ts1, ts2) =>                   | TC_ARROW (r, ts1, ts2) =>
720                       tcc_arw(r, map tc_norm ts1, map tc_norm ts2)                       tcc_arw(r, map tc_norm ts1, map tc_norm ts2)
721                   | TC_PARROW (t1, t2) => tcc_parw(tc_norm t1, tc_norm t2)                   | TC_PARROW (t1, t2) => tcc_parw(tc_norm t1, tc_norm t2)
# Line 840  Line 785 
785           (eqop1(a1, a2)) andalso (eqlist(eqop2, b1, b2))           (eqop1(a1, a2)) andalso (eqlist(eqop2, b1, b2))
786       | (TC_SEQ ts1, TC_SEQ ts2) => eqlist(eqop1, ts1, ts2)       | (TC_SEQ ts1, TC_SEQ ts2) => eqlist(eqop1, ts1, ts2)
787       | (TC_SUM ts1, TC_SUM ts2) => eqlist(eqop1, ts1, ts2)       | (TC_SUM ts1, TC_SUM ts2) => eqlist(eqop1, ts1, ts2)
788       | (TC_TUPLE (_, ts1), TC_TUPLE (_, ts2)) => eqlist(eqop1, ts1, ts2)       | (TC_TUPLE ts1, TC_TUPLE ts2) => eqlist(eqop1, ts1, ts2)
789       | (TC_ABS a, TC_ABS b) => eqop1(a, b)       | (TC_ABS a, TC_ABS b) => eqop1(a, b)
790       | (TC_ABS a, _) => eqop3(a, t2)       | (TC_ABS a, _) => eqop3(a, t2)
791       | (_, TC_ABS b) => eqop3(t1, b)       | (_, TC_ABS b) => eqop3(t1, b)
# Line 950  Line 895 
895              end)              end)
896    end (* function lt_eqv_bx *)    end (* function lt_eqv_bx *)
897    
 (***************************************************************************  
  *  UTILITY FUNCTIONS ON FINDING OUT THE DEPTH OF THE FREE TYC VARIABLES   *  
  ***************************************************************************)  
 (** finding out the innermost binding depth for a tyc's free variables *)  
 fun tc_depth (x, d) =  
   let val tvs = tc_vs (tc_norm x)  
       (* unfortunately we have to reduce everything to the normal form  
          before we can talk about its list of free type variables.  
        *)  
    in case tvs  
        of NONE => bug "unexpected case in tc_depth"  
         | SOME [] => DI.top  
         | SOME (a::_) => d + 1 - (#1(tvFromInt a))  
   end  
   
 fun tcs_depth ([], d) = DI.top  
   | tcs_depth (x::r, d) = Int.max(tc_depth(x, d), tcs_depth(r, d))  
   
898  end (* toplevel local *)  end (* toplevel local *)
899  end (* abstraction LtyKernel *)  end (* abstraction LtyKernel *)
900    

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

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