Merge pull request #81 from MatthewFluet/int-inf-consts

IntInf constants updates.

Various updates to treatment of IntInf constants in the compiler. Highlights:
 * Recognize both Big and Small representations of IntInfs.
 * Translate IntInf consts to Big and Small representations in
   conversion from SSA to RSSA. This is consistent with the
   treatment of other IntInf operations in the conversion. After
   the conversion, IntInf is no longer treated as a primitive.
 * Remove initIntInfs from program initialization.
 * Constant fold IntInf_toVector and WordVector_toIntInf
   primitives.

include/common-main.h

@@ -22,10 +22,6 @@
 #define DeclareProfileLabel(l)                  \
         extern char l __attribute__ ((weak))
 
-#define BeginIntInfInits static struct GC_intInfInit intInfInits[] = {
-#define IntInfInitElem(g, n) { g, n },
-#define EndIntInfInits };
-
 #define BeginVectorInits static struct GC_vectorInit vectorInits[] = {
 #define VectorInitElem(es, gi, l, w) { es, gi, l, w },
 #define EndVectorInits };
@@ -44,8 +40,6 @@ PRIVATE Pointer gcStateAddress;
         gcState.frameLayoutsLength = cardof(frameLayouts);              \
         gcState.globals = (objptr*)globalObjptr;                        \
         gcState.globalsLength = cardof(globalObjptr);                   \
-        gcState.intInfInits = intInfInits;                              \
-        gcState.intInfInitsLength = cardof(intInfInits);                \
         gcState.loadGlobals = loadGlobals;                              \
         gcState.magic = mg;                                             \
         gcState.maxFrameSize = mfs;                                     \

mlton/atoms/const.fun

@@ -17,26 +17,69 @@ structure ConstType = ConstType (struct
                                     structure WordSize = WordX.WordSize
                                  end)
 
-structure SmallIntInf =
+structure IntInfRep =
    struct
       structure WordSize = WordX.WordSize
-
-      fun toWord (i: IntInf.t): WordX.t option =
+      datatype t = Big of WordXVector.t | Small of WordX.t
+      fun fromIntInf (i: IntInf.t) : t =
          let
-            val ws = WordSize.smallIntInfWord ()
-            val ws' = WordSize.fromBits (Bits.- (WordSize.bits ws, Bits.one))
+            val sws = WordSize.smallIntInfWord ()
+            val sws' = WordSize.fromBits (Bits.- (WordSize.bits sws, Bits.one))
          in
-            if WordSize.isInRange (ws', i, {signed = true})
-               then SOME (WordX.orb (WordX.one ws,
-                                     WordX.lshift (WordX.fromIntInf (i, ws),
-                                                   WordX.one ws)))
-               else NONE
+            if WordSize.isInRange (sws', i, {signed = true})
+               then Small (WordX.orb (WordX.one sws,
+                                      WordX.lshift (WordX.fromIntInf (i, sws), WordX.one sws)))
+            else let
+                    val bws = WordSize.bigIntInfWord ()
+                    val bbws = Bits.toWord (WordSize.bits bws)
+                    val mask = IntInf.- (WordSize.cardinality bws, IntInf.one)
+                    fun loop (i, acc) =
+                       if IntInf.isZero i
+                          then Big (WordXVector.fromListRev ({elementSize = bws}, acc))
+                       else let
+                               val quot = IntInf.~>> (i, bbws)
+                               val rem = IntInf.andb (i, mask)
+                            in
+                               loop (quot, (WordX.fromIntInf (rem, bws)) :: acc)
+                            end
+                 in
+                    loop (if IntInf.>= (i, IntInf.zero)
+                             then (i, [WordX.zero bws])
+                          else (IntInf.~ i, [WordX.one bws]))
+                 end
+         end
+      fun smallToIntInf (w: WordX.t): IntInf.t option =
+         let
+            val sws = WordSize.smallIntInfWord ()
+            val one = WordX.one sws
+         in
+            if WordSize.equals (WordX.size w, sws)
+               andalso WordX.isOne (WordX.andb (w, one))
+               then SOME (WordX.toIntInfX (WordX.rshift (w, one, {signed = true})))
+            else NONE
+         end
+      fun bigToIntInf (v: WordXVector.t): IntInf.t option =
+         let
+            val bws = WordSize.bigIntInfWord ()
+            val bbws = Bits.toWord (WordSize.bits bws)
+         in
+            if WordSize.equals (WordXVector.elementSize v, bws)
+               andalso WordXVector.length v >= 2
+               then let
+                       val v0 = WordXVector.sub (v, 0)
+                       fun mag () =
+                          WordXVector.foldFrom
+                          (v, 1, IntInf.zero, fn (w, i) =>
+                           IntInf.andb (IntInf.<< (i, bbws), WordX.toIntInf w))
+                    in
+                       if WordX.isZero v0
+                          then SOME (mag ())
+                       else if WordX.isOne v0
+                          then SOME (IntInf.~ (mag ()))
+                       else NONE
+                    end
+            else NONE
          end
-
-      val isSmall = isSome o toWord
-
-      fun fromWord (w: WordX.t): IntInf.t =
-         WordX.toIntInfX (WordX.rshift (w, WordX.one (WordX.size w), {signed = true}))
    end
 
 datatype t =

mlton/atoms/const.sig

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2014 Matthew Fluet.
  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -23,11 +23,12 @@ signature CONST =
       sharing ConstType.RealSize = RealX.RealSize
       sharing ConstType.WordSize = WordX.WordSize
 
-      structure SmallIntInf:
+      structure IntInfRep:
          sig
-            val fromWord: WordX.t -> IntInf.t
-            val isSmall: IntInf.t -> bool
-            val toWord: IntInf.t -> WordX.t option
+            datatype t = Big of WordXVector.t | Small of WordX.t
+            val bigToIntInf: WordXVector.t -> IntInf.t option
+            val fromIntInf: IntInf.t -> t
+            val smallToIntInf: WordX.t -> IntInf.t option
          end
 
       datatype t =

mlton/atoms/prim.fun

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009-2010 Matthew Fluet.
+(* Copyright (C) 2009-2010,2014 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -1438,7 +1438,7 @@ val extractTargs =
    fn z =>
    Trace.trace ("Prim.extractTargs", layout o #1, Layout.ignore) extractTargs z
 
-structure SmallIntInf = Const.SmallIntInf
+structure IntInfRep = Const.IntInfRep
 
 structure ApplyArg =
    struct
@@ -1550,6 +1550,8 @@ fun ('a, 'b) apply (p: 'a t,
       fun word (w: WordX.t): ('a, 'b) ApplyResult.t =
          ApplyResult.Const (Const.word w)
       val wordOpt = fn NONE => ApplyResult.Unknown | SOME w => word w
+      fun wordVector (v: WordXVector.t): ('a, 'b) ApplyResult.t =
+         ApplyResult.Const (Const.wordVector v)
       fun iio (f, c1, c2) = intInf (f (c1, c2))
       fun wordS (f: WordX.t * WordX.t * {signed: bool} -> WordX.t,
                  (_: WordSize.t, sg),
@@ -1655,9 +1657,13 @@ fun ('a, 'b) apply (p: 'a t,
                 end
            | (IntInf_equal, [IntInf i1, IntInf i2]) => bool (i1 = i2)
            | (IntInf_toWord, [IntInf i]) =>
-                (case SmallIntInf.toWord i of
-                    NONE => ApplyResult.Unknown
-                  | SOME w => word w)
+                (case IntInfRep.fromIntInf i of
+                    IntInfRep.Big _ => ApplyResult.Unknown
+                  | IntInfRep.Small w => word w)
+           | (IntInf_toVector, [IntInf i]) =>
+                (case IntInfRep.fromIntInf i of
+                    IntInfRep.Big v => wordVector v
+                  | IntInfRep.Small _ => ApplyResult.Unknown)
            | (_, [IntInf i1, IntInf i2, _]) => intInfBinary (i1, i2)
            | (_, [IntInf i1, Word w2, _]) => intInfShiftOrToString (i1, w2)
            | (_, [IntInf i1, _]) => intInfUnary (i1)
@@ -1724,11 +1730,18 @@ fun ('a, 'b) apply (p: 'a t,
                 wordS (WordX.rshift, s, w1, w2)
            | (Word_sub _, [Word w1, Word w2]) => word (WordX.sub (w1, w2))
            | (Word_subCheck s, [Word w1, Word w2]) => wcheck (op -, s, w1, w2)
-           | (Word_toIntInf, [Word w]) => intInf (SmallIntInf.fromWord w)
+           | (Word_toIntInf, [Word w]) =>
+                (case IntInfRep.smallToIntInf w of
+                    NONE => ApplyResult.Unknown
+                  | SOME i => intInf i)
            | (Word_extdToWord (_, s, {signed}), [Word w]) =>
                 word (if signed then WordX.resizeX (w, s)
                       else WordX.resize (w, s))
            | (Word_xorb _, [Word w1, Word w2]) => word (WordX.xorb (w1, w2))
+           | (WordVector_toIntInf, [WordVector v]) =>
+                (case IntInfRep.bigToIntInf v of
+                    NONE => ApplyResult.Unknown
+                  | SOME i => intInf i)
            | _ => ApplyResult.Unknown)
              handle Chr => ApplyResult.Unknown
                   | Div => ApplyResult.Unknown

mlton/atoms/word-x-vector.fun

@@ -62,8 +62,14 @@ fun equals (v, v') =
     WordSize.equals (elementSize v, elementSize v')
     andalso Vector.equals (elements v, elements v', WordX.equals)
 
+fun foldFrom (v, start, b, f) = Vector.foldFrom (elements v, start, b, f)
+
 fun forall (v, f) = Vector.forall (elements v, f)
 
+fun fromListRev ({elementSize}, l) =
+   T {elementSize = elementSize,
+      elements = Vector.fromListRev l}
+
 fun fromString s =
    T {elementSize = WordSize.byte,
       elements = Vector.tabulate (String.size s, fn i =>

mlton/atoms/word-x-vector.sig

@@ -21,8 +21,10 @@ signature WORD_X_VECTOR =
 
       val elementSize: t -> WordSize.t
       val equals: t * t -> bool
+      val foldFrom: t * int * 'b * (WordX.t * 'b -> 'b) -> 'b
       val forall: t * (WordX.t -> bool) -> bool
       val fromString: string -> t
+      val fromListRev: {elementSize: WordSize.t} * WordX.t list -> t
       val hash : t -> word
       val layout: t -> Layout.t
       val length: t -> int

mlton/backend/backend.fun

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009,2013 Matthew Fluet.
+(* Copyright (C) 2009,2013-2014 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -424,11 +424,6 @@ let
                (all, get)
             end
       in
-         val (allIntInfs, globalIntInf) =
-            make (IntInf.equals,
-                  fn i => (IntInf.toString i,
-                           Type.intInf (),
-                           i))
          val (allReals, globalReal) =
             make (RealX.equals,
                   fn r => (RealX.toString r,
@@ -458,10 +453,8 @@ let
             datatype z = datatype Const.t
          in
             case c of
-               IntInf i =>
-                  (case Const.SmallIntInf.toWord i of
-                      NONE => globalIntInf i
-                    | SOME w => M.Operand.Cast (M.Operand.Word w, Type.intInf ()))
+               IntInf _ =>
+                  Error.bug "Backend.constOperand: IntInf"
              | Null => M.Operand.Null
              | Real r => globalReal r
              | Word w => M.Operand.Word w
@@ -1148,7 +1141,6 @@ in
        frameLayouts = frameLayouts,
        frameOffsets = frameOffsets,
        handlesSignals = handlesSignals,
-       intInfs = allIntInfs (), 
        main = main,
        maxFrameSize = maxFrameSize,
        objectTypes = objectTypes,

mlton/backend/machine.fun

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2014 Matthew Fluet.
  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -793,7 +793,6 @@ structure Program =
                                         size: Bytes.t} vector,
                          frameOffsets: Bytes.t vector vector,
                          handlesSignals: bool,
-                         intInfs: (Global.t * IntInf.t) list,
                          main: {chunkLabel: ChunkLabel.t,
                                 label: Label.t},
                          maxFrameSize: Bytes.t,
@@ -877,7 +876,7 @@ structure Program =
          end
 
       fun typeCheck (program as
-                     T {chunks, frameLayouts, frameOffsets, intInfs,
+                     T {chunks, frameLayouts, frameOffsets,
                         maxFrameSize, objectTypes, profileInfo, reals,
                         vectors, ...}) =
          let
@@ -979,10 +978,6 @@ structure Program =
                globals ("real", reals,
                         fn (t, r) => Type.equals (t, Type.real (RealX.size r)),
                         RealX.layout)
-            val _ =
-               globals ("intInf", intInfs,
-                        fn (t, _) => Type.isSubtype (t, Type.intInf ()),
-                        IntInf.layout)
             val _ =
                globals ("vector", vectors,
                         fn (t, v) =>

mlton/backend/machine.sig

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009,2014 Matthew Fluet.
  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -263,7 +263,6 @@ signature MACHINE =
                       *)
                      frameOffsets: Bytes.t vector vector,
                      handlesSignals: bool,
-                     intInfs: (Global.t * IntInf.t) list,
                      main: {chunkLabel: ChunkLabel.t,
                             label: Label.t},
                      maxFrameSize: Bytes.t,

mlton/backend/ssa-to-rssa.fun

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009,2011 Matthew Fluet.
+(* Copyright (C) 2009,2011,2014 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -605,15 +605,6 @@ fun convertWordSize (ws: WordSize.t): WordSize.t =
 fun convertWordX (w: WordX.t): WordX.t =
    WordX.resize (w, convertWordSize (WordX.size w))
 
-fun convertConst (c: Const.t): Const.t =
-   let
-      datatype z = datatype Const.t
-   in
-      case c of
-         Word w => Word (convertWordX w)
-       | _ => c
-   end
-
 fun convert (program as S.Program.T {functions, globals, main, ...},
              {codegenImplementsPrim: Rssa.Type.t Rssa.Prim.t -> bool}): Rssa.Program.t =
    let
@@ -1019,7 +1010,21 @@ fun convert (program as S.Program.T {functions, globals, main, ...},
                      fun move (src: Operand.t) = maybeMove (fn _ => src)
                   in
                      case exp of
-                        S.Exp.Const c => move (Const (convertConst c))
+                        S.Exp.Const c =>
+                           (case c of
+                               Const.IntInf i =>
+                                  let
+                                     fun doit c =
+                                        maybeMove (fn ty => Operand.cast (Const c, ty))
+                                  in
+                                     case Const.IntInfRep.fromIntInf i of
+                                        Const.IntInfRep.Big v =>
+                                           doit (Const.WordVector v)
+                                      | Const.IntInfRep.Small w =>
+                                           doit (Const.Word w)
+                                  end
+                             | Const.Word w => move (Const (Const.Word (convertWordX w)))
+                             | _ => move (Const c))
                       | S.Exp.Inject {variant, ...} =>
                            if isSome (toRtype ty)
                               then move (varOp variant)
@@ -1434,7 +1439,7 @@ fun convert (program as S.Program.T {functions, globals, main, ...},
                                              (Prim.wordExtdToWord
                                               (s1, s2, {signed = signed}))
                                        end
-                               | WordVector_toIntInf => move (a 0)
+                               | WordVector_toIntInf => cast ()
                                | Word8Array_subWord s => subWord s
                                | Word8Array_updateWord s =>
                                        let

mlton/codegen/amd64-codegen/amd64-codegen.fun

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009-2010 Matthew Fluet.
+(* Copyright (C) 2009-2010,2014 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -98,7 +98,6 @@ struct
                      frameLayouts, 
                      frameOffsets, 
                      handlesSignals, 
-                     intInfs, 
                      main, 
                      maxFrameSize, 
                      objectTypes, 
@@ -112,7 +111,6 @@ struct
                    frameLayouts = frameLayouts, 
                    frameOffsets = frameOffsets, 
                    handlesSignals = handlesSignals, 
-                   intInfs = intInfs,  
                    main = main, 
                    maxFrameSize = maxFrameSize, 
                    objectTypes = objectTypes,