[<<][meta][>>][..]
Thu Dec 8 22:55:57 EST 2011

So is it ready?

Apart from some cosmetics (see Sys existentials in previous posts) it
seems that most of it is working.  I managed to generate some C code
representing a composition of 3 integrators:

  type AC t = Atom (Code t)
  f :: (AC Tfloat, AC Tfloat) -> MCode (AC Tfloat, AC Tfloat)
  f (Atom s, Atom i) = do
    s' <- add s i
    return (Atom s', Atom s')

  fi = Atom $ lit 0


  t5 = term $ compileSysLL fi $ (f,fi) <-- (f,fi) <-- (f,fi)

Which gives

  void fun()
  {
      {
          float fun0_0;
          float fun0_1;
          float fun0_2;
          {
              fun0_0 = 0.0;
              fun0_1 = 0.0;
              fun0_2 = 0.0;
              goto fun0;
          }
      fun0:
          {
              const float a1 = fun0_0;
              const float a2 = fun0_1;
              const float a3 = fun0_2;
              const float r4 = add(a3, 0.0);
              const float r5 = add(a2, r4);
              const float r6 = add(a1, r5);
              fun0_0 = r6;
              fun0_1 = r5;
              fun0_2 = r4;
              goto fun0;
          }
      }
  }

The next step is to fill in arrays.  

I updated compileLoop to include arrays.  This required a bit of type
annotation due to 2 occurances of lit.  Is there a way around that?

  compileLoop
    :: (Struct stx r su s,
        StructRepr r,
        StructPrim stx r Int,
        Array m r arri i,
        Array m r arro o,
        Loop stx m r,
        TMLprim o) =>
       r (arri i)
       -> r (arro o)
       -> r Tint
       -> ((s, Atom (r i)) -> m (s, Atom (r o)))
       -> s
       -> m (r Tint)

  compileLoop arri arro arrn update init =
    _letrec open body where
      open loop =
        _lambda (\(s, Atom n) -> do
                    i <- _get arri n
                    (s', Atom o) <- update (s, Atom i)
                    _set arro n o
                    more <- lt n arrn
                    _if more 
                      (do
                          n' <- add n (lit 1)
                          _app loop (s', Atom n'))
                      _exit)
      body loop =
        _app loop (init, Atom $ lit 0)

  varArr :: String -> Code (ACode Tfloat)
  varArr name =  Code $ Ref $ Var (Type AFloat [()]) name

  t7 = term $ compileLoop (varArr "in") (varArr "out") (lit 64) f (Atom $ lit 0)


Gives the following result, which is ready except for the outer
function body and serialization of loop state.

  *Main> c t7
  void fun()
  {
      {
          float fun0_0;
          int fun0_1;
          {
              fun0_0 = 0.0;
              fun0_1 = 0;
              goto fun0;
          }
      fun0:
          {
              const float a1 = fun0_0;
              const int a2 = fun0_1;
              const float r3 = *add(in, a2);
              const float r4 = add(a1, r3);
              *add(out, a2) = r4;
              const int r5 = lt(a2, 64);
              const int r6 = add(a2, 1);
              if (r5)
              {
                  fun0_0 = r4;
                  fun0_1 = r6;
                  goto fun0;
              }
              else
              {
                  return 0;
              }
          }
      }
  }


Wait, there's a bug still in the code gen monad.  If should delimit
context inside the blocks.  The 'mBlock' was missing.

  _if (Code c) mx my = do
    (Code x) <- mBlock mx
    (Code y) <- mBlock my
    return $ Code $ If c x y


Which gives the following:

  *Main> c t7
  void fun()
  {
      {
          float fun0_0;
          int fun0_1;
          {
              fun0_0 = 0.0;
              fun0_1 = 0;
              goto fun0;
          }
      fun0:
          {
              const float a1 = fun0_0;
              const int a2 = fun0_1;
              const float r3 = *add(in, a2);
              const float r4 = add(a1, r3);
              *add(out, a2) = r4;
              const int r5 = lt(a2, 64);
              if (r5)
              {
                  const int r6 = add(a2, 1);
                  fun0_0 = r4;
                  fun0_1 = r6;
                  goto fun0;
              }
              else
              {
                  return 0;
              }
          }
      }
  }



[Reply][About]
[<<][meta][>>][..]