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/primop-branch-2/src/compiler/Semant/statenv/prim.sml
ViewVC logotype

View of /sml/branches/primop-branch-2/src/compiler/Semant/statenv/prim.sml

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1956 - (download) (annotate)
Thu Jul 6 20:13:39 2006 UTC (14 years, 11 months ago) by macqueen
File size: 13420 byte(s)
new prim.sml that doesn't depend on Primop
(* Copyright 1996 by AT&T Bell Laboratories *)
(* prim.sml *)

signature PRIM_ENV = 
  val primEnv : StaticEnv.staticEnv
end (* signature PRIM_ENV *)

structure PrimEnv : PRIM_ENV = 

  structure S = Symbol
  structure M = Modules
  structure B = Bindings
  structure SP = SymPath
  structure IP = InvPath
  structure SE = StaticEnv
  structure EE = EntityEnv

  structure BT = BasicTypes
  structure T = Types
  structure TU = TypesUtil
  structure MU = ModuleUtil

  structure ST = Stamps
  structure V = VarCon

  structure A = Access


fun mkTycElement (name: string, tyc) = 
     (S.tycSymbol name, M.TYCspec{entVar=ST.special name, spec=tyc, repl=false,

 * Note: this function only applies to constructors but not exceptions;
 * exceptions will have a non-trivial slot number 
fun mkConElement (name, d) = 
    (S.varSymbol name, M.CONspec{spec=d, slot=NONE})

(* Below there is a bunch of very long list literals which would create
 * huge register pressure on the compiler.  We construct them backwards
 * using an alternative "cons" that takes its two arguments in opposite
 * order.  This effectively puts the lists' ends to the left and alleviates
 * this effect. (Stupid ML trick No. 21b) (Blume, 1/2001) *)
infix :-:				(* inverse :: *)
fun l :-: e = e :: l

(* primTypes structure *)
val primTypes =
  let val primTycs =
	  [] :-:
             ("bool", BT.boolTycon) :-:
             ("list", BT.listTycon) :-:
             ("ref", BT.refTycon) :-:
             ("unit", BT.unitTycon) :-:
             ("int", BT.intTycon) :-:
             ("int32", BT.int32Tycon) :-:
             ("int64", BT.int64Tycon) :-:
	     ("intinf", BT.intinfTycon) :-:
             ("real", BT.realTycon) :-:
             ("word", BT.wordTycon) :-:
             ("word8", BT.word8Tycon) :-:
             ("word32", BT.word32Tycon) :-:
             ("word64", BT.word64Tycon) :-:
             ("cont", BT.contTycon) :-:
             ("control_cont", BT.ccontTycon) :-:
             ("array", BT.arrayTycon) :-:
             ("vector", BT.vectorTycon) :-:
             ("object", BT.objectTycon) :-:
             ("c_function", BT.c_functionTycon) :-:
             ("word8array", BT.word8arrayTycon) :-:
             ("real64array", BT.real64arrayTycon) :-:
             ("spin_lock", BT.spin_lockTycon) :-:
             ("string", BT.stringTycon) :-:
             ("char", BT.charTycon) :-:
             ("exn", BT.exnTycon) :-:
             ("frag", BT.fragTycon) :-:
             ("susp", BT.suspTycon)

      val primCons = 
          [] :-:
	     ("true", BT.trueDcon) :-:
             ("false", BT.falseDcon) :-:
             ("::", BT.consDcon) :-:
             ("nil", BT.nilDcon) :-:
             ("ref", BT.refDcon) :-:
             ("QUOTE", BT.QUOTEDcon) :-:
             ("ANTIQUOTE", BT.ANTIQUOTEDcon) :-:
             ("$", BT.dollarDcon)

      val tycElements = map mkTycElement primTycs
      val conElements = map mkConElement primCons

      val allElements = tycElements@conElements
      val allSymbols = map #1 allElements

      val entities = let
	  fun f ((_,M.TYCspec{spec,entVar,repl,scope}),r) =
	      EE.bind(entVar,M.TYCent spec,r)
	    | f _ = ErrorMsg.impossible "primTypes:entities"
          foldr f EE.empty tycElements

      val entities = EntityEnv.mark(fn _ => ST.special"primEntEnv", entities)

      val sigrec = 
	  {stamp=ST.special "PrimTypesSig",
	   name=SOME(S.sigSymbol "PRIMTYPES"), closed=true,
	   properties = PropList.newHolder (),
	   (* boundeps=ref (SOME []), *)
	   (* lambdaty=ref(NONE), *)
	   stub = NONE}
      val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])
      val strrec =
	  {sign=M.SIG sigrec,
	   rlzn={stamp=ST.special "PrimTypesStr",
		 properties = PropList.newHolder (),
		 (* lambdaty=ref NONE,  *)
		 rpath=IP.IPATH[S.strSymbol "primTypes"]},
	   access=A.nullAcc, info= II.mkStrInfo []}
   in M.STR strrec

  end (* primTypes *)

 *                 BUILDING A COMPLETE LIST OF PRIMOPS                    *

(* We generate unique numbers for each primop, and bind them as components
of a structure InLine, with the generic type all = (All 'a).'a. The primop
intrinsic types will be specified in a separate table used in the translate
phase (and FLINT?).

val v1 = T.IBOUND 0
fun p1 t = T.POLYty {sign=[false], tyfun=T.TYFUN {arity=1, body=t}}
(* the generic type (All 'a).'a *)
val all = T.POLYty {sign=[false], tyfun=T.TYFUN {arity=1, body=T.IBOUND 0}}

val allPrimops =

end (* local *)

(* uList structure *)
val uList =
  let val ev = ST.special "uListVar"
      val allElements = 
            [(S.tycSymbol "list", M.TYCspec{spec=BT.ulistTycon,entVar=ev,
              mkConElement("nil", BT.unilDcon),
              mkConElement("::", BT.uconsDcon)]
      val allSymbols = map #1 allElements
      val sigrec = {stamp=ST.special "uListSig",
		       name=NONE, closed=true, 
		       symbols=allSymbols, elements=allElements,
		       typsharing=nil, strsharing=nil,
		       properties = PropList.newHolder (),
		       (* boundeps=ref (SOME []), *)
		       (* lambdaty=ref NONE, *)
		       stub = NONE}
      val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])
   in M.STR{sign=M.SIG sigrec,
            rlzn={stamp=ST.special "uListStr",
		  entities=EE.bind(ev,M.TYCent BT.ulistTycon,EE.empty),
		  properties = PropList.newHolder (),
		  (* lambdaty=ref(NONE), *)
		  rpath=IP.IPATH[S.strSymbol "uList"]},
            access=A.nullAcc, info= II.mkStrInfo[]}

(* inLine structure *)
val inLine =
  let val bottom = T.POLYty{sign=[false], 
                            tyfun=T.TYFUN{arity=1,body=T.IBOUND 0}}

      fun mkVarElement(name,(symbols,elements,primElems,offset)) =
        let val s = S.varSymbol name
            val sp = M.VALspec{spec=bottom, slot=offset}
                    (* using universal generic type bottom for all components *)
            val p = PrimOpId.PrimE(PrimOpId.Prim offset) (* the primop code *)
         in (s::symbols, (s,sp)::elements, p::primElems, offset+1)
      val (allSymbols, allElements, primList, _) = 
            foldl mkVarElement ([],[],[],0) allPrimops

      val (allSymbols, allElements, primList) = 
            (rev allSymbols, rev allElements, rev primList)

      val sigrec ={stamp=ST.special "inLineSig",
		   name=NONE, closed=true, 
		   symbols=allSymbols, elements=allElements,
		   typsharing=nil, strsharing=nil,
		   properties = PropList.newHolder (),  (* dbm: ??? *)
		   stub = NONE}

      val _ = ModulePropLists.setSigBoundeps (sigrec, SOME [])

   in M.STR{sign = M.SIG sigrec,
            rlzn = {stamp=ST.special "inLineStr",
		    properties = PropList.newHolder (),  (* dbm: ??? *)
		    rpath=IP.IPATH[S.strSymbol "inLine"]},
	    access = A.nullAcc,
            info = primList}

(* priming structures: PrimTypes and InLine *)
val nameofPT = S.strSymbol "PrimTypes"
val nameofUL = S.strSymbol "UnrolledList"
val nameofIL = S.strSymbol "InLine"

val primEnv =
      SE.bind(nameofIL,B.STRbind inLine,
          SE.bind(nameofUL,B.STRbind uList,
  	     SE.bind(nameofPT,B.STRbind primTypes,

val primEnv = let
    val { hash, pickle, ... } =
	PickMod.pickleEnv (PickMod.INITIAL ModuleId.emptyTmap) primEnv
    UnpickMod.unpickleEnv (fn _ => ModuleId.emptyTmap) (hash, pickle)

end (* local *)
end (* structure PrimEnv *)

ViewVC Help
Powered by ViewVC 1.0.0