path: root/compiler/standardClient.ey

< # sys extensions
  # TODO: handle EINTR correctly

  0 _ ==RDONLY
  1 _ ==WRONLY
  2 _ ==RDWR
      bor bor ==RWMASK

  1 ==PROTREAD
  2 ==PROTWRITE
  4 ==PROTEXEC

  2 ==MAPPRIVATE
  32 ==MAPANONYMOUS
  
  0 ==READ
  1 ==WRITE
  2 ==OPEN
  3 ==CLOSE

  9 ==MMAP
  11 ==MUNMAP

  { < ==mode ==flags ==fd <
      { flags RWMASK bnot band RDONLY bor =flags } /readonly deff
      { flags RWMASK bnot band WRONLY bor =flags } /writeonly deff
      { flags RWMASK bnot band RDWR bor =flags } /readwrite deff
      { ==path
        fd 0 ge { "file already open" die } rep 
        path "\0" cat flags mode 0 0 0 OPEN sys .asm .syscall -- _ =fd
        0 lt { "cannot open " path cat die } rep
      } /open deff
      {
        fd 0 0 0 0 0 CLOSE sys .asm .syscall --
        0 lt { "bad things happened to your close call" die } rep
      } /close deff
      { ==count
        fd 0 lt { "file not open" die } rep 
        count str .alloc ==buf
        fd buf count 0 0 0 READ sys .asm .syscall -- _
        0 lt { "read failed" die } rep
        buf str .inplacePrefix
      } /read deff
      { ==buf
        fd 0 lt { "file not open" die } rep 
        fd buf _ len 0 0 0 WRITE sys .asm .syscall -- _
        0 lt { "write failed" die } rep
      } /write deff
      { ==buf
        fd 0 lt { "file not open" die } rep 
        { buf len } { 
          fd buf _ len 0 0 0 WRITE sys .asm .syscall -- _
          0 lt { "write failed" die } rep
          buf str .postfix =buf
        } loop
      } /writeall deff
  > > -- } /makefile deff

  { # 0777 = 511
    1 neg RDONLY 511 makefile
  } /file sys .deff

  0 RDONLY 0 makefile /in sys .defv
  1 WRONLY 0 makefile /out sys .defv
  2 WRONLY 0 makefile /err sys .defv

  < # sys .asm extensions
    { ==reqAddr ==reqSize
      <
        reqAddr
        reqSize
        PROTEXEC PROTREAD PROTWRITE bor bor
        MAPPRIVATE MAPANONYMOUS bor
        1 neg
        0
        MMAP sys .asm .syscall -- _
        0 lt { "mmap failed" die } rep

        ==base
        reqSize ==size

        {
          base size 0 0 0 0 MUNMAP sys .asm .syscall --
          0 lt { "munmap failed" die } rep
        } =*free
      >
    } /allocAt sys .asm .deff

    {
      0 sys .asm .allocAt
    } /alloc sys .asm .deff
  > --

  < # sys .typed extensions

    # Returns an array which lists the sequence of curried arguments
    # i.e. if f: A -> B -> C -> D -> E the result will be [ A B C D ]
    { ==object
      { "unknown type in typeStack" die } ==unknown
      { "invalid type in typeStack" die } ==invalid
      { [ object 0 1 neg ] } ==literal

      object sys .typed .type [
        literal # integer
        literal # string
        literal # scope
        invalid # name table
        invalid # extension area
        { object sys .typed .inputs ==in
          in len 1 neq { "multi-input function in typeStack" die } rep
          [ 0 in * 0 1 neg ]
          object sys .typed .outputs ==out
          out len 1 neq { "multi-output function in typeStack" die } rep
          0 out * typeStackInternal
        } # function
        invalid # function code
        { [ 1 0 object len 1 sub ] 0 object * typeStackInternal } # array
        invalid # function type
        unknown
        unknown
        unknown
        unknown
        unknown
        unknown
        unknown
      ] * *
    } /typeStackInternal deff

    { [ -01 typeStackInternal ] } /typeStack deff

    { -- 0 } /isVariableType deff

    { ==t
      t len 3 neq { "complex execution type non-triple" die } rep

      { "unknown type in typeStack" die } ==unknown
      { "invalid type in typeStack" die } ==invalid

      2 t * 1 t * ge
    } /isIterableType deff

    { ==arr
      0
    } /getLoopStart deff

    { ==arr
      arr len eq
    } /isLoopEnd deff

    { ==arr
      1 add
    } /doLoopStep deff

    # Executing a function f: A->B->C (i.e. B A f) on concrete arguments b a.
    # Phase 1
    #   Foreach argument:
    #     Find the function input type from top of concrete argument type stack,
    #       increase viewport from top of concrete type stack
    #         match type from bottom to top, if type cannot be found, create constant function
    #         final match is that which creates minimal number of constant function layers
    # Phase 2
    #   Foreach argument type:
    #     Identify the type stack above the match from phase 1.
    #     Run from right (stacktop) argument to left (stacklow) argument:
    #       Take topmost type, check whether it can be found in other stacks (from top)
    #         Eliminate all matching types via function or loop creation
    { _ ==f sys .typed .inputs ==inputs
      [ ] ==concreteArgs
      [ ] ==viewPortOffset

      # Phase 1
      0 inputs len 1 sub range reverse {
        # print "Analyzing arg: %d"
        inputs * typeStack ==formalTypeStack
        _ ==c typeStack ==concreteTypeStack
        # "Type-Stack: %d" Dumper($concreteTypeStack) die

        0 ==bestViewPortSize
        concreteTypeStack len 1 add ==bestViewPortMatch

        # "Formal Type Stack: @$formalTypeStack\n" print
        # "       Type Stack: @$concreteTypeStack\n" print

        1 neg concreteTypeStack * isVariableType {
          1 concreteTypeStack len range { ==viewPortSize
            [ 0 viewPortSize 1 sub range { concreteTypeStack * } each ] ==typeViewPort # explicit each here
            # "@$formalTypeStack vs. @$concreteTypeStack\n" print

            formalTypeStack concreteTypeStack typeMismatchCount ==viewPortMatch # FIXME this line seems fishy
            viewPortMatch bestViewPortMatch lt {
              viewPortSize =bestViewPortSize
              viewPortMatch =bestViewPortMatch
            } rep
          } each
        } {
          concreteTypeStack len =bestViewPortSize
          0 =bestViewPortMatch
        } ? *

        # convert concrete argument to exactly matching function
        # ... which calls the concrete argument using its relevant args
        bestViewPortMatch {
          # if argument is concrete, but we need are construction a function overall, then concrete
          # argument needs to be converted to a constant function in whatever domain is necessary
          "concrete argument constant functionification needs to be implemented, mismatch: $bestViewPortMatch" die
          { "magic goes here FIXME" die } =c
        } {
          # zero mismatches, can directly use concrete argument
          [ concreteTypeStack len formalTypeStack len sub ] viewPortOffset cat =viewPortOffset
        } ? *

        [ c ] concreteArgs cat =concreteArgs
      } each

      # "Viewport Offsets: @viewPortOffset\n" print

      # Phase 2,
      [
        0 viewPortOffset len 1 sub range { ==i
          i concreteArgs * typeStack ==remaining
          [ 0 i viewPortOffset * 1 sub range { remaining * } each ] # explicit each here
        } each
      ] ==toBeAbstractedTypes

      "toBeAbstractedTypes: " dump
      toBeAbstractedTypes dump

      [ toBeAbstractedTypes { len } each ] any not {
        # no types need to be abstracted, function can be called
        concreteArgs _ dump _ len dearray f
        "attempting to call function (w.o. abstraction)" dump
        *
      } {
        [ ] ==argTypes # the type stack of the new function
        [ ] ==stageCalls # which functions to call in each stage
        [ ] ==loops # undef for lambda abstraction, loop bound source for loops

        0 toBeAbstractedTypes len 1 sub range reverse { ==i
          { i toBeAbstractedTypes * len } {
            # TODO: create a decent shift
            [ i toBeAbstractedTypes * reverse _ len dearray ==type ] reverse i toBeAbstractedTypes =[]
              [ i ] ==stageCalls2
              1 neg ==iterationSource
              type isIterableType { i =iterationSource } rep

              0 i 1 sub range reverse { ==j
                j toBeAbstractedTypes * len not not {
                  0 j toBeAbstractedTypes * * type commonSubType # -> <type> <any exists>
                  { =type
                    iterationSource 0 lt type isIterableType and { j =iterationSource } rep
                    # TODO: create a decent shift
                    [ j toBeAbstractedTypes * reverse _ len dearray -- ] reverse j toBeAbstractedTypes =[]
                    [ j ] stageCalls2 cat =stageCalls2
                  } rep
                } rep
              } each

              iterationSource 0 ge {
                [ 1 neg ] argTypes cat =argTypes
                [ iterationSource ] loops cat =loops
              } {
                [ type ] argTypes cat =argTypes
                [ 1 neg ] loops cat =loops
              } ? *
            stageCalls [ stageCalls2 ] cat =stageCalls
          } loop
        } each

        "concreteArgs: " dump
        concreteArgs dump
        "stageCalls: " dump
        stageCalls dump
        "argTypes: " dump
        argTypes dump
        "loops: " dump
        loops dump
        
        { ==loops ==argTypes ==stageCalls ==concreteArgs
          stageCalls len not {
            concreteArgs _ len dearray f
            *
          } {
            [ stageCalls _ len dearray ==stage ] =stageCalls
            [ argTypes _ len dearray ==argType ] =argTypes
            [ loops _ len dearray ==loopIndex ] =loops
            loopIndex 0 ge {
              [ ] ==results
              loopIndex concreteArgs * ==loopedOver
              loopedOver getLoopStart ==i
              { i loopedOver isLoopEnd not } {
                [ concreteArgs _ len dearray ] ==concreteArgsCopy
                stage { ==j
                  # TODO: think about a single function returning multiple values
                  i j concreteArgs * * j concreteArgsCopy =[]
                } each

                [ concreteArgsCopy stageCalls argTypes loops unravel ]
                results -01 cat =results
                results dump
                # TODO: think about a single function returning multiple values
                # should be solved by producing two arrays side by side

                i loopedOver doLoopStep =i
              } loop

              results
              # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]];
              # FIXME the undef can be determined
            } {
              { ==v
                stage { ==i
                  v i concreteArgs * * i concreteArgs =[]
                } each

                concreteArgs stageCalls argTypes loops unravel
              } # leave this on the stack
              # push @$data, [$abstraction, ['func', 'autoabstraction of ' . $f->[1]->[1], [grep { $_ } @argTypeCopy], undef]];
              # FIXME the undef can be determined
            } ? *
          } ? *
        } =*unravel

        concreteArgs stageCalls argTypes loops unravel

        "execution complete" dump
      } ? *
    } /execute sys .typed .deff
  > --
> --

# global extensions
<
  [ /0 /1 /2 /3 /4 /5 /6 /7 /8 /9 /A /B /C /D /E /F ] ==base16singleDigits
  [ base16singleDigits { ==first base16singleDigits { first -01 cat } each } each ] ==base16digits

  {
    [ -01 8 { _ 256 mod base16digits * -01 256 div } rep -- ]
    reverse |cat fold
  } /base16encode64 deff

  { ==indent _ ==o
    { "unknown type in dump" die } ==unknown
    { "invalid type in dump" die } ==invalid
        
    "" indent { "  " cat } rep sys .err .writeall
    sys .typed .type [
      { o base16encode64 sys .err .writeall } # integer
      { "\"" o "\"" cat cat sys .err .writeall } # string
      { "<scope>" } # scope
      invalid # name table
      invalid # extension area
      { "<function>" } # function
      invalid # function code
      {
        "[\n" sys .err .writeall
        o { indent 1 add dumpIndented } each
        "" indent { "  " cat } rep "]" cat sys .err .writeall
      } # array
      invalid # function type
      unknown
      unknown
      unknown
      unknown
      unknown
      unknown
      unknown
    ] * *
    "\n" sys .err .writeall
  } /dumpIndented deff

  # dump top stack element to sys .err
  { 0 dumpIndented }
> -- /dump deff

# vim: syn=elymas