tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

float-quantize-fast.tri (7315B)

      1 -- Benchmark-only variants; Q is the unchanged single-round control.
      2 !import native_math as N
      3 !import kernels as K
      4 !import quantize as Q
      5 !import pipelines as P
      6 !export *
      7 drop2 x = K.tail (K.tail x)
      8 drop4 x = drop2 (drop2 x)
      9 drop8 x = drop4 (drop4 x)
     10 drop16 x = drop8 (drop8 x)
     11 drop32 x = drop16 (drop16 x)
     12 splice1 x suffix = t (K.head x) suffix
     13 splice2 x suffix = splice1 x (splice1 (K.tail x) suffix)
     14 splice4 x suffix = splice2 x (splice2 (drop2 x) suffix)
     15 splice8 x suffix = splice4 x (splice4 (drop4 x) suffix)
     16 splice16 x suffix = splice8 x (splice8 (drop8 x) suffix)
     17 splice32 x suffix = splice16 x (splice16 (drop16 x) suffix)
     18 -- Only used with a nonzero normal exponent: low zero bits remain canonical.
     19 pack exponent m = splice32 m (splice16 (drop32 m) (splice4 (drop16 (drop32 m)) exponent))
     20 encode scale m inexact = K.lazy
     21   (_ : Q.answer Q.infinity (t t) t)
     22   (_ : K.lazy (_ : Q.answer m inexact (t t))
     23     (_ : Q.answer (pack (N.successor (N.subtract scale 1230)) m) inexact t)
     24     (N.lt m 4503599627370496)) (N.gt scale 3275)
     25 -- Packing-only ablation: retain the control's scans and general shifts.
     26 normalizePack scale m inexact = K.lazy
     27   (_ : Q.answer 0 inexact (t t))
     28   (_ : let pad = Q.min (N.subtract 53 (K.width m)) (N.subtract scale 1230) in
     29     encode (N.subtract scale pad) (P.shiftLeft pad m) inexact) (N.zero m)
     30 carryPack scale m inexact = K.lazy
     31   (_ : normalizePack (N.successor scale) (K.tail m) inexact)
     32   (_ : normalizePack scale m inexact) (N.gt (K.width m) 53)
     33 packing scale n = K.lazy (_ : Q.answer 0 t (t t))
     34   (_ : let cut = Q.max (N.subtract (K.width n) 53) (N.subtract 1230 scale) in
     35     let rounded = K.roundL cut n in
     36     carryPack (N.add scale cut) (K.head rounded) (K.tail rounded)) (N.zero n)
     37 -- Fixed positive shifts compose power-of-two blocks; pad <=52, n>0.
     38 zeros1 n = t t n
     39 zeros2 n = zeros1 (zeros1 n)
     40 zeros4 n = zeros2 (zeros2 n)
     41 zeros8 n = zeros4 (zeros4 n)
     42 zeros16 n = zeros8 (zeros8 n)
     43 zeros32 n = zeros16 (zeros16 n)
     44 shiftPositive count n =
     45   K.choose (zeros32 (shift16 count n)) (shift16 count n) (N.odd (K.tail (drop4 count)))
     46 shift16 count n = K.choose (zeros16 (shift8 count n)) (shift8 count n) (N.odd (drop4 count))
     47 shift8 count n = K.choose (zeros8 (shift4 count n)) (shift4 count n) (N.odd (K.tail (drop2 count)))
     48 shift4 count n = K.choose (zeros4 (shift2 count n)) (shift2 count n) (N.odd (drop2 count))
     49 shift2 count n = K.choose (zeros2 (shift1 count n)) (shift1 count n) (N.odd (K.tail count))
     50 shift1 count n = K.choose (zeros1 n) n (N.odd count)
     51 -- Share rounded width, including carry correction. Same one rounding call.
     52 normalizeFast scale m width inexact = K.lazy
     53   (_ : Q.answer 0 inexact (t t))
     54   (_ : let pad = Q.min (N.subtract 53 width) (N.subtract scale 1230) in
     55     encode (N.subtract scale pad) (shiftPositive pad m) inexact) (N.zero m)
     56 carryFast scale m inexact = let width = K.width m in K.lazy
     57   (_ : normalizeFast (N.successor scale) (K.tail m) (N.predecessor width) inexact)
     58   (_ : normalizeFast scale m width inexact) (N.gt width 53)
     59 fast scale n = K.lazy (_ : Q.answer 0 t (t t))
     60   (_ : let cut = Q.max (N.subtract (K.width n) 53) (N.subtract 1230 scale) in
     61     let rounded = K.roundL cut n in
     62     carryFast (N.add scale cut) (K.head rounded) (K.tail rounded)) (N.zero n)
     63 normalizeCached scale m width inexact = K.lazy
     64   (_ : Q.answer 0 inexact (t t))
     65   (_ : let pad = Q.min (N.subtract 53 width) (N.subtract scale 1230) in
     66     encode (N.subtract scale pad) (P.shiftLeft pad m) inexact) (N.zero m)
     67 carryCached scale m inexact = let width = K.width m in K.lazy
     68   (_ : normalizeCached (N.successor scale) (K.tail m) (N.predecessor width) inexact)
     69   (_ : normalizeCached scale m width inexact) (N.gt width 53)
     70 cached scale n = K.lazy (_ : Q.answer 0 t (t t))
     71   (_ : let cut = Q.max (N.subtract (K.width n) 53) (N.subtract 1230 scale) in
     72     let rounded = K.roundL cut n in
     73     carryCached (N.add scale cut) (K.head rounded) (K.tail rounded)) (N.zero n)
     74 controlOne x = Q.quantize (K.head x) (K.tail x)
     75 packingOne x = packing (K.head x) (K.tail x)
     76 fastOne x = fast (K.head x) (K.tail x)
     77 control xs = K.map controlOne xs
     78 packed xs = K.map packingOne xs
     79 optimized xs = K.map fastOne xs
     80 packOne x = pack (K.head x) (K.tail x)
     81 packs xs = K.map packOne xs
     82 shiftOne x = shiftPositive (K.head x) (K.tail x)
     83 shifts xs = K.map shiftOne xs
     84 zeroPacking x = packing (Q.spin x) 0
     85 zeroFast x = fast (Q.spin x) 0
     86 cachedOne x = cached (K.head x) (K.tail x)
     87 cachedWidths xs = K.map cachedOne xs
     88 zeroCached x = cached (Q.spin x) 0
     89 -- Bounded near-alignment ablations: same fast quantizer, different exact shift.
     90 nearGenericOne x = let scale = K.head x in let rest = K.tail x in
     91   let gap = K.head rest in let ab = K.tail rest in
     92   fast scale (N.add (P.shiftLeft gap (K.head ab)) (K.tail ab))
     93 nearSpliceOne x = let scale = K.head x in let rest = K.tail x in
     94   let gap = K.head rest in let ab = K.tail rest in
     95   fast scale (N.add (shiftPositive gap (K.head ab)) (K.tail ab))
     96 nearGenericSubOne x = let scale = K.head x in let rest = K.tail x in
     97   let gap = K.head rest in let ab = K.tail rest in
     98   fast scale (N.subtract (P.shiftLeft gap (K.head ab)) (K.tail ab))
     99 nearSpliceSubOne x = let scale = K.head x in let rest = K.tail x in
    100   let gap = K.head rest in let ab = K.tail rest in
    101   fast scale (N.subtract (shiftPositive gap (K.head ab)) (K.tail ab))
    102 nearGenericAdds xs = K.map nearGenericOne xs
    103 nearSpliceAdds xs = K.map nearSpliceOne xs
    104 nearGenericSubtracts xs = K.map nearGenericSubOne xs
    105 nearSpliceSubtracts xs = K.map nearSpliceSubOne xs
    106 packLowDemand x = K.head (pack (Q.spin x) (t (t t) (Q.spin x)))
    107 zeroShiftDemand x = K.head (shiftPositive 0 (t (t t) (Q.spin x)))
    108 -- Select zero/one-bit shifts directly before the six-stage block dispatcher.
    109 shiftSelective count n = K.triage n (_ : n)
    110   (bit rest : K.lazy (_ : K.choose (zeros1 n) n bit)
    111     (_ : shiftPositive count n) (N.zero rest)) count
    112 normalizeSelective scale m width inexact = K.lazy
    113   (_ : Q.answer 0 inexact (t t))
    114   (_ : let pad = Q.min (N.subtract 53 width) (N.subtract scale 1230) in
    115     encode (N.subtract scale pad) (shiftSelective pad m) inexact) (N.zero m)
    116 carrySelective scale m inexact = let width = K.width m in K.lazy
    117   (_ : normalizeSelective (N.successor scale) (K.tail m) (N.predecessor width) inexact)
    118   (_ : normalizeSelective scale m width inexact) (N.gt width 53)
    119 selective scale n = K.lazy (_ : Q.answer 0 t (t t))
    120   (_ : let cut = Q.max (N.subtract (K.width n) 53) (N.subtract 1230 scale) in
    121     let rounded = K.roundL cut n in
    122     carrySelective (N.add scale cut) (K.head rounded) (K.tail rounded)) (N.zero n)
    123 selectiveOne x = selective (K.head x) (K.tail x)
    124 selected xs = K.map selectiveOne xs
    125 selectShiftOne x = shiftSelective (K.head x) (K.tail x)
    126 selectShifts xs = K.map selectShiftOne xs
    127 zeroSelective x = selective (Q.spin x) 0
    128 zeroSelectiveShift x = K.head (shiftSelective 0 (t (t t) (Q.spin x)))
    129 nearSelectOne x = let scale = K.head x in let rest = K.tail x in
    130   let gap = K.head rest in let ab = K.tail rest in
    131   fast scale (N.add (shiftSelective gap (K.head ab)) (K.tail ab))
    132 nearSelectSubOne x = let scale = K.head x in let rest = K.tail x in
    133   let gap = K.head rest in let ab = K.tail rest in
    134   fast scale (N.subtract (shiftSelective gap (K.head ab)) (K.tail ab))
    135 nearSelectAdds xs = K.map nearSelectOne xs
    136 nearSelectSubtracts xs = K.map nearSelectSubOne xs