Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/branches/SMLNJ/src/compiler/FLINT/kernel/primtyc.sml
ViewVC logotype

View of /sml/branches/SMLNJ/src/compiler/FLINT/kernel/primtyc.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 69 - (download) (annotate)
Fri Apr 3 00:06:55 1998 UTC (21 years, 6 months ago) by monnier
File size: 5797 byte(s)
*** empty log message ***
(* Copyright 1996 - 1998 by YALE FLINT PROJECT *)
(* primtyc.sml *)

structure PrimTyc :> PRIM_TYC = 
struct

local fun bug s = ErrorMsg.impossible ("PrimTyc: " ^ s)

in

(* 
 * This datatype defines the set of primitive type constructors. They 
 * probably don't have to be defined as a datatype. A environment-like
 * thing would serve better. The intermediate language can be thought
 * as a language parameterized by the set of primitive type constructors
 * and primitive functions --- which can be represented by a higher-order
 * functors. By the way, PT_VOID is an object we know nothing but that 
 * it is a pointer; or so-called canonical word representations; on a 
 * 32-bit machine, it can be a Pointer or a 31-bit integer; on 64-bit 
 * machines, it could be something else. In the future, we should also 
 * add arrow_kind and tuple_kind, or even array_kind, and vector_kind to 
 * denote various possible representation types. (ZHONG)
 *)

datatype ptyc
  = PT_INT31                         (* 31-bit integer *)
  | PT_INT32                         (* 32-bit integer *)
  | PT_REAL                          (* 64-bit real *)
  | PT_STRING                        (* string type; always a pointer *)
  | PT_EXN                           (* exception type *)

  | PT_ARRAY                         (* the polymorphic array tyc *)
  | PT_VECTOR                        (* the polymorphic vector tyc *)
  | PT_REF                           (* the polymorphic reference tyc *)
  | PT_LIST                          (* the polymorphic list tyc *)
  | PT_ETAG                          (* the exception tag type *)

  | PT_CONT                          (* the general-continuation tyc *)
  | PT_CCONT                         (* the control-continuation tyc *)
  | PT_ARROW                         (* the function tyc *)
  | PT_OPTION                        (* the option tyc is optional *)

  | PT_BOXED                         (* the boxed tyc; used for wrapping *)
  | PT_TGD                           (* the tagged tyc; with a integer *)
  | PT_UTGD                          (* the untagged tyc; no int tags *)
  | PT_TNSP                          (* the transparent tyc; fit-in-1-word *)

  | PT_DYN                           (* the dynamic type; with runtime ty *)
  | PT_VOID                          (* generic machine word; supports GC *)
  | PT_OBJ
  | PT_CFUN
  | PT_BARRAY
  | PT_RARRAY
  | PT_SLOCK

(** the primtive type constructor *)
type primtyc = ptyc * int * int

(** the set of primitive type constructors *)
val ptc_int31  = (PT_INT31, 0,  1)
val ptc_int32  = (PT_INT32, 0,  2)
val ptc_real   = (PT_REAL,  0,  3)     
val ptc_string = (PT_STRING,0,  4)   
val ptc_exn    = (PT_EXN,   0,  5)      
val ptc_void   = (PT_VOID,  0,  6)     
val ptc_array  = (PT_ARRAY, 1,  7)    
val ptc_vector = (PT_VECTOR,1,  8)   
val ptc_ref    = (PT_REF,   1,  9)      
val ptc_list   = (PT_LIST,  1, 10)     
val ptc_etag   = (PT_ETAG,  1, 11)
val ptc_cont   = (PT_CONT,  1, 12)
val ptc_ccont  = (PT_CCONT, 1, 13)    
val ptc_arrow  = (PT_ARROW, 2, 14)    
val ptc_option = (PT_OPTION,1, 15)   
val ptc_boxed  = (PT_BOXED, 1, 16)
val ptc_tgd    = (PT_TGD,   1, 17)      
val ptc_utgd   = (PT_UTGD,  1, 18)     
val ptc_tnsp   = (PT_TNSP,  1, 19)     
val ptc_dyn    = (PT_DYN,   1, 20)      
val ptc_obj    = (PT_OBJ,   0, 21)
val ptc_cfun   = (PT_CFUN,  0, 22)
val ptc_barray = (PT_BARRAY,0, 23)
val ptc_rarray = (PT_RARRAY,0, 24)
val ptc_slock  = (PT_SLOCK, 0, 25)


(** get the arity of a particular primitive tycon *)
fun pt_arity(_, i, _) = i

(** each primitive type constructor is equipped with a key *)
fun pt_toint (_, _, k) = k

fun pt_fromint k = 
  (case k 
    of  1 => ptc_int31  
     |  2 => ptc_int32  
     |  3 => ptc_real   
     |  4 => ptc_string 
     |  5 => ptc_exn    
     |  6 => ptc_void   
     |  7 => ptc_array  
     |  8 => ptc_vector 
     |  9 => ptc_ref    
     | 10 => ptc_list   
     | 11 => ptc_etag
     | 12 => ptc_cont   
     | 13 => ptc_ccont  
     | 14 => ptc_arrow  
     | 15 => ptc_option 
     | 16 => ptc_boxed  
     | 17 => ptc_tgd    
     | 18 => ptc_utgd   
     | 19 => ptc_tnsp   
     | 20 => ptc_dyn    
     | 21 => ptc_obj
     | 22 => ptc_cfun
     | 23 => ptc_barray
     | 24 => ptc_rarray
     | 25 => ptc_slock
     | _ => bug "unexpected integer in pt_fromint")

(** printing out the primitive type constructor *)
fun pt_print (pt, _, _) =
  let fun g (PT_INT31)  = "I"
        | g (PT_INT32)  = "W"
        | g (PT_REAL)   = "F"
        | g (PT_STRING) = "N"      
        | g (PT_EXN)    = "X" 
        | g (PT_ARRAY)  = "A"       
        | g (PT_VECTOR) = "V"      
        | g (PT_REF)    = "P"         
        | g (PT_LIST)   = "L"        
        | g (PT_ETAG)   = "G"        
        | g (PT_CONT)   = "D"       
        | g (PT_CCONT)  = "C"       
        | g (PT_ARROW)  = "R"       
        | g (PT_OPTION) = "O"
        | g (PT_BOXED)  = "K"
        | g (PT_TGD)    = "T"
        | g (PT_UTGD)   = "U"
        | g (PT_TNSP)   = "S"
        | g (PT_DYN)    = "Y"
        | g (PT_VOID)   = "Z"
        | g (PT_OBJ)    = "OB"
        | g (PT_CFUN)   = "CF"
        | g (PT_BARRAY) = "BA"
        | g (PT_RARRAY) = "RA"
        | g (PT_SLOCK)  = "SL"
   in g pt
  end

(** check the boxity of values of each prim tyc *)
fun unboxed ((PT_INT32 | PT_REAL), _, _) = true
  | unboxed _ = false 

fun bxupd ((PT_INT31 | PT_INT32 | PT_REAL), _, _) = false
  | bxupd ((PT_LIST | PT_OPTION | PT_VOID), _, _) = false
  | bxupd ((PT_TNSP | PT_TGD | PT_UTGD | PT_BOXED | PT_DYN), _, _) = false
  | bxupd _ = true

fun ubxupd (PT_INT31, _, _) = true
  | ubxupd _ = false

fun isvoid ((PT_INT31 | PT_INT32 | PT_REAL | PT_STRING), _, _) = false
  | isvoid _ = true

end (* toplevel local *)
end (* structure PrimTyc *)


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