home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / basics / access.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  8.0 KB  |  220 lines
  1. (* access.sml
  2.  *
  3.  * COPYRIGHT (c) 1989 by AT&T Bell Laboratories
  4.  *)
  5.  
  6. structure Access : ACCESS =
  7. struct
  8.  
  9.   structure P = 
  10.     struct
  11.     (* Various primitive operations.  Those that are designated "inline" are
  12.      * expanded into lambda representation in the InlineOps structure.
  13.      *)
  14.       datatype primop
  15.     = IADD | ISUB | IMUL | IDIV | INEG    (* integer arithmetic *)
  16.     | IGE | IGT | ILE | ILT            (* integer comparisons *)
  17.     | LESSU | GEQU                (* unsigned comparisons *)
  18.     | IEQL | INEQ                (* integer (and pointer) equality *)
  19.     | FADDd | FSUBd | FMULd | FDIVd | FNEGd    (* double precision arithmetic *)
  20.         | FABSd                    (* double precision abs *)
  21.     | FGEd | FGTd | FLEd | FLTd        (* double precision comparisons *)
  22.     | FEQLd | FNEQd                (* double precision equality *)
  23.     | POLYEQL | POLYNEQ            (* polymorphic equality *)
  24.     | BOXED | UNBOXED            (* boxity tests *)
  25.         | LENGTH                (* vector, string, array, ... length *)
  26.         | OBJLENGTH                (* length of arbitrary heap object *)
  27.     | CAST
  28.     | GETHDLR | SETHDLR            (* get/set exn handler pointer *)
  29.     | GETVAR | SETVAR            (* get/set var register *)
  30.     | MAKEREF                (* allocate a ref cell *)
  31.     | CALLCC | CAPTURE | THROW        (* continuation operations *)
  32.     | STORE                    (* bytearray update *)
  33.     | INLSTORE                (* inline bytearray update *)
  34.     | ORDOF                    (* string subscript *)
  35.     | INLORDOF                (* inline string subscript *)
  36.     | INLBYTEOF                (* inline bytearray subscript *)
  37.     | DEREF                    (* dereferencing *)
  38.     | ASSIGN                (* assignment; this is short for *)
  39.                         (* an update operation *)
  40.     | UPDATE                (* array update (maybe boxed) *)
  41.     | INLUPDATE                (* inline array update (maybe boxed) *)
  42.     | BOXEDUPDATE                (* boxed array update *)
  43.     | UNBOXEDUPDATE                (* unboxed array update *)
  44.     | SUBSCRIPT                (* array subscript *)
  45.     | INLSUBSCRIPT                (* inline array subscript *)
  46.     | FLOOR                    (* double precision -> int conversion *)
  47.     | ROUND                    (* UNIMPLEMENTED *)
  48.     | REAL                    (* int -> double precision conversion *)
  49.     | SUBSCRIPTV                (* vector subscript *)
  50.     | INLSUBSCRIPTV                (* inline vector subscript *)
  51.     | FSUBSCRIPTd                (* real array subscript *)
  52.     | INLFSUBSCRIPTd            (* inline real array subscript *)
  53.     | FUPDATEd                (* real array update *)
  54.     | INLFUPDATEd                (* inline real array update *)
  55.     | RSHIFT | LSHIFT            (* logical shifts *)
  56.     | ORB | ANDB | XORB | NOTB        (* bit-wise logical operations *)
  57.     | GETTAG                (* extract the tag portion of an *)
  58.                         (* object's descriptor as an ML int *)
  59.     | MKSPECIAL                (* make a special object *)
  60.     | SETSPECIAL                (* set the state of a special object *)
  61.     | GETSPECIAL                (* get the state of a special object *)
  62.     | USELVAR | DEFLVAR
  63.  
  64.       fun pr_primop DEREF = "!"
  65.         | pr_primop IMUL = "*" 
  66.         | pr_primop IADD  = "+"
  67.         | pr_primop ISUB = "-"
  68.         | pr_primop ASSIGN = ":="
  69.         | pr_primop ILT  = "<"
  70.         | pr_primop ILE = "<="
  71.         | pr_primop IGT  = ">"
  72.         | pr_primop IGE = ">="
  73.         | pr_primop LESSU = "lessu"
  74.         | pr_primop GEQU = "gequ"
  75.         | pr_primop BOXED = "boxed"
  76.         | pr_primop UNBOXED = "unboxed"
  77.         | pr_primop IDIV = "div"
  78.         | pr_primop CAST = "cast"
  79.         | pr_primop POLYEQL = "polyeql"
  80.     | pr_primop POLYNEQ = "polyneq"  
  81.         | pr_primop FADDd = "faddd"
  82.         | pr_primop FDIVd = "fdivd"
  83.         | pr_primop FEQLd = "feqld"
  84.         | pr_primop FGEd  = "fged"
  85.         | pr_primop FGTd  = "fgtd"
  86.         | pr_primop FLEd = "fled"
  87.         | pr_primop FLTd = "fltd"
  88.         | pr_primop FMULd = "fmuld"
  89.         | pr_primop FNEQd = "fneqd"
  90.         | pr_primop FSUBd = "fsubd"
  91.         | pr_primop FNEGd = "fnegd"
  92.         | pr_primop FABSd = "fabsd"
  93.         | pr_primop GETHDLR = "gethdlr"
  94.         | pr_primop IEQL = "ieql"
  95.         | pr_primop INEQ = "ineq"
  96.         | pr_primop MAKEREF = "makeref"
  97.         | pr_primop ORDOF = "ordof"
  98.         | pr_primop SETHDLR = "sethdlr"
  99.         | pr_primop LENGTH = "length"
  100.         | pr_primop OBJLENGTH = "objlength"
  101.         | pr_primop CALLCC = "callcc"
  102.         | pr_primop CAPTURE = "capture"
  103.         | pr_primop THROW = "throw"
  104.         | pr_primop STORE = "store"
  105.         | pr_primop SUBSCRIPT = "subscript"
  106.         | pr_primop BOXEDUPDATE = "boxedupdate"
  107.         | pr_primop UNBOXEDUPDATE = "unboxedupdate"
  108.         | pr_primop UPDATE = "update"
  109.         | pr_primop INEG = "~"
  110.         | pr_primop INLSUBSCRIPT = "inlsubscript"
  111.         | pr_primop INLSUBSCRIPTV = "inlsubscriptv"
  112.         | pr_primop INLUPDATE = "inlupdate"
  113.         | pr_primop INLBYTEOF = "inlbyteof"
  114.         | pr_primop INLSTORE = "inlstore"
  115.         | pr_primop INLORDOF = "inlordof"
  116.         | pr_primop FLOOR = "floor"
  117.         | pr_primop ROUND = "round"
  118.         | pr_primop REAL = "real"
  119.         | pr_primop FSUBSCRIPTd = "subscriptf"
  120.         | pr_primop FUPDATEd = "updatef"
  121.         | pr_primop INLFSUBSCRIPTd = "inlsubscriptf"
  122.         | pr_primop INLFUPDATEd = "inlupdatef"
  123.         | pr_primop SUBSCRIPTV = "subscriptv"
  124.         | pr_primop RSHIFT = "rshift"
  125.         | pr_primop LSHIFT = "lshift"
  126.         | pr_primop ORB = "orb"
  127.         | pr_primop ANDB = "andb"
  128.         | pr_primop XORB = "xorb"
  129.         | pr_primop NOTB = "notb"
  130.         | pr_primop GETVAR = "getvar"
  131.         | pr_primop SETVAR = "setvar"
  132.     | pr_primop GETTAG = "GETTAG"
  133.     | pr_primop MKSPECIAL = "MKSPECIAL"
  134.     | pr_primop SETSPECIAL = "SETSPECIAL"
  135.     | pr_primop GETSPECIAL = "GETSPECIAL"
  136.         | pr_primop USELVAR = "uselvar"
  137.         | pr_primop DEFLVAR = "deflvar"
  138.     end
  139.  
  140.   type lvar = int      (* lambda variable id number *)
  141.   type slot = int      (* position in structure record *)
  142.   type path = int list (* slot chain terminated by lambda variable id number *)
  143.   type primop = P.primop
  144.  
  145.   (* access: how to find the dynamic value corresponding to a variable.
  146.     A PATH is an absolute address from a lambda-bound variable (i.e. we find
  147.     the value of the lambda-bound variable, and then do selects from that).
  148.     PATH's are kept in reverse order.   A SLOT is a position in a structure,
  149.     and is relative to the address of the lambda-bound variable for the
  150.     structure.   INLINE means that there is no dynamic value for the variable,
  151.     which is a closed function: instead the compiler will generate "inline"
  152.     code for the variable.  If we need a dynamic value, we must eta-expand
  153.     the function.
  154.  
  155.     See modules.sig for the invariants of access paths in environments *)
  156.  
  157.   datatype access 
  158.     = SLOT of slot
  159.     | PATH of path  
  160.     | INLINE of primop
  161.  
  162.   datatype conrep
  163.       = UNTAGGED
  164.       | TAGGED of int
  165.       | TAGGEDREC of int * int
  166.       | UNTAGGEDREC of int
  167.       | CONSTANT of int
  168.       | TRANSPARENT
  169.       | REF
  170.       | VARIABLE of access (* exception constructor *)
  171.       | VARIABLEc of access (* exception constructor with no argument *)
  172.  
  173. (* the different kinds of records *)
  174.   datatype record_kind
  175.     = RK_VECTOR
  176.     | RK_RECORD
  177.     | RK_SPILL
  178.     | RK_CLOSURE
  179.     | RK_CONT
  180.  
  181.   (* local *)
  182.     val varcount = ref 0
  183.     exception NoLvarName
  184.     val lvarNames : string Intmap.intmap = Intmap.new(32, NoLvarName)
  185.     val name = Intmap.map lvarNames
  186.     val giveLvarName = Intmap.add lvarNames
  187.  
  188.   val saveLvarNames = System.Control.saveLvarNames
  189.   fun mkLvar () : lvar = (inc varcount; !varcount)
  190.   fun sameName(v,w) =
  191.       if !saveLvarNames
  192.       then giveLvarName(v,name w)
  193.          handle NoLvarName => (giveLvarName(w, name v)
  194.                       handle NoLvarName => ())
  195.       else ()
  196.   fun dupLvar v =
  197.       (inc varcount;
  198.        if !saveLvarNames
  199.        then giveLvarName(!varcount,name v) handle NoLvarName => ()
  200.        else ();
  201.        !varcount)
  202.   fun namedLvar(id: Symbol.symbol) =
  203.       (inc varcount;
  204.        if !saveLvarNames then giveLvarName(!varcount,Symbol.name id) else ();
  205.        !varcount)
  206.   fun lvarName(lv : lvar) : string =
  207.       (name lv ^ makestring lv) handle NoLvarName => makestring lv
  208.  
  209.   fun pr_lvar(lvar:lvar) = makestring(lvar)
  210.   fun pr_slot(slot:slot) = makestring(slot)
  211.   fun pr_path'[] = "]"
  212.     | pr_path'[x:int] = makestring x ^ "]"
  213.     | pr_path'((x:int)::rest)= makestring x ^ "," ^ pr_path' rest
  214.   fun pr_path path = "[" ^ pr_path' path
  215.   fun pr_access (SLOT slot) = "SLOT(" ^ pr_slot slot ^ ")"
  216.     | pr_access (PATH path) = "PATH(" ^ pr_path path ^ ")"
  217.     | pr_access (INLINE po) = "INLINE(" ^ P.pr_primop po ^ ")"
  218.  
  219. end  (* structure Access *)
  220.