path: root/compiler/elymasAsmLib.ey

"elymasAsm.ey" include

<
  { assembler -01 . } ":" deff
  assembler .|label "@" deff
  "%" _ : -01 deff

  <
    1 ==PROT_READ
    2 ==PROT_WRITE
    4 ==PROT_EXEC

    2 ==MAP_PRIVATE
    16 ==MAP_FIXED
    32 ==MAP_ANONYMOUS
  > ==MMAP

  <
    9 ==mmap
  > ==SYSCALL

  { =*def ==struct
    struct values |cat fold :arrayToCode .base ==address
    struct keys { address -101 def struct -01 . len address add =address } each
  } /allocateOffsetStruct deff

  { ==str
    [
      str len :imm64 -- %10
      %00 %00 %00 %00 %00 %00 %00 %00
      str len :imm64
    ] str strToUTF8Bytes cat
    [ 8 str len 8 mod sub %00 rep ] cat
  } /toConstString deff

  [ ] ==stringHoles
  [ ] ==stringValues

  { ==str
    ] _ len ==offset
    stringValues [ str ] cat =stringValues
    stringHoles [ { ==allocatedStrings ==opcodes
      [ allocatedStrings str . :imm64 ] =*bytesToPatch
      0 7 range { _ bytesToPatch -01 offset add opcodes =[] } each
    } ] cat =stringHoles
    [ -011 len dearray %00 %00 %00 %00 %00 %00 %00 %00
  } /string deff

  { ==opcodes
    stringValues len 0 gt {
      < < stringValues { _ toConstString -01 == }' each > { defv }' allocateOffsetStruct > ==allocatedStrings
      stringHoles { opcodes allocatedStrings -102 * } each
      [ ] =stringHoles
      [ ] =stringValues
    } rep

    opcodes
  } /stringResolve deff

  [ ] ==linkHoles

  { ==what ==where
    ] _ len ==offset
    linkHoles [ { =*resolve
      [ what resolve :imm64 ] =*bytesToPatch
      0 7 range { _ bytesToPatch -01 where resolve offset add add sys .asm .poke } each
    } ] cat =linkHoles
    [ -011 len dearray %00 %00 %00 %00 %00 %00 %00 %00
  } /linkAbs64 deff

  { ==resolve
    linkHoles { resolve -01 * } each
    [ ] =linkHoles
  } /linkResolve deff

  <
    # current end of heap memory (grows upwards)
    [ %00 %00 %00 %00 %00 %60 %00 %00 ] ==heapEnd

    # next free byte at end of heap
    [ %00 %00 %00 %00 %00 %60 %00 %00 ] ==unusedHeapStart
    
    # current parser scope
    [ %00 %00 %00 %00 %00 %00 %00 %00 ] ==currentScope

    # current parser quote state
    [ %00 %00 %00 %00 %00 %00 %00 %00 ] ==currentQuoted
  > { defv }' allocateOffsetStruct

  { _ =*array len _ 4 div ==largeMoves
                    4 mod ==smallMoves
    0 ==i
    largeMoves {
      i _ 4 add =i
        _ [ 3 2 1 0 ] add array { -01 256 mul add } fold -01 /rdi :movlImmMemDisp8
    } rep
    i /rdi :addqImm8Reg
    smallMoves {
      i _ 1 add =i
          array /rdi :movbImmMem
      /rdi :incqReg
    } rep
  } /loadToRdi deff

  # internal functions, ABI follows SysV standards

  # compare two strings
  # rdi -> address of first string
  # rsi -> address of second string
  # rax <- 1 if both strings are equal, 0 otherwise
  [
    /rax /rax :xorqRegReg
    :cmpsq # ignore memory length header
    :cmpsq # ignore hash
    /rsi /rdx :movqMemReg # load exact length
    :cmpsq # same exact length
    /fail :jnzLbl8
    /rdx /rcx :movqRegReg
    :repz :cmpsb
    /fail :jnzLbl8
    /rax :incqReg
    @fail
  ] :labelResolve /internalStringEqualsCode defv

  <
    # dump string to stderr for internal error reporting
    # rdi -> address of string on heap
    [
      24 /rdi /rsi :leaqMemDisp8Reg
      16 /rdi /rdx :movqMemDisp8Reg
      2 /rdi :movqImmReg
      1 /rax :movqImmReg
      :syscall
      :retn
    ] /internalDumpErrorString defv

    # allocate a chunk of memory
    # rdi -> size of chunk in bytes
    # rax <- address of allocated chunk
    #        chunk will have GC length header initialized correctly
    # FIXME put a real allocator here
    [
      /rbx :pushqReg
      /rdi :pushqReg
      unusedHeapStart /rax :movqImmReg
      /rax /rcx :movqMemReg
      /rcx /rbx :movqRegReg
      /rcx /rdx :movqRegReg
      /rdi /rcx :addqRegReg
      /rcx /rax :movqRegMem
      heapEnd /rax :movqImmReg
      /rax /rdi :movqMemReg
      /rdi /rcx :cmpqRegReg
      [
        4096 4096 mul /rsi :movqImmReg
        /rsi /rdi :addqRegReg
        /rdi /rax :movqRegMem
        /rsi /rdi :subqRegReg

        SYSCALL .mmap /rax :movqImmReg
        # /rdi already fine
        # /rsi already fine
        < { MMAP -01 . } "!" deff
          !PROT_READ !PROT_WRITE !PROT_EXEC bor bor /rdx :movqImmReg
          !MAP_PRIVATE !MAP_FIXED !MAP_ANONYMOUS bor bor /r10 :movqImmReg
        > --
        /r8 :movqImmOOBReg %FF %FF %FF %FF %FF %FF %FF %FF
        0 /r9 :movqImmReg
        :syscall
      ] |len { :jbeRel8 } -21*0*221* dearray
      /rbx /rax :movqRegReg
      /rdi :popqReg
      /rdi /rax :movqRegMem
      /rbx :popqReg
      :retn
    ] /internalAllocate defv

    # compare two strings
    # rdi -> address of first string
    # rsi -> address of second string
    # rax <- 1 if both strings are equal, 0 otherwise
    [
      internalStringEqualsCode _ len dearray
      :retn
    ] /internalStringEquals defv

    # resolve element from scope
    # rdi -> address of scope on the heap
    # rsi -> address of element name on the heap
    # rax <- address of element on the heap (0 if nonexistant)
    # rdx <- 0 if element is passive
    #        1 if element is active
    #        2 if element is quote-active
    # rcx <- address of entry (i.e. where rdx was loaded from)
    [
      @retryWithParent

      8 /rdi /rcx :movqMemDisp8Reg # load name table
      /rcx /rdx :movqRegReg
      16 /rdx :addqImm8Reg # rdx will iterate over entries
      8 /rcx /rcx :addqMemDisp8Reg # compute name table effective end

      @loop
      /rdx /rcx :cmpqRegReg
      /end :jbeLbl8
      # TODO this is ridiculous
      /rdi :pushqReg
      /rsi :pushqReg
      /rdx :pushqReg
      /rcx :pushqReg
      /rdx /rdi :movqMemReg
      internalStringEqualsCode _ len dearray
      /rcx :popqReg
      /rdx :popqReg
      /rsi :popqReg
      /rdi :popqReg

      /rax /rax :testqRegReg
      /found :jnzLbl8

      16 /rdx :addqImm8Reg
      /loop :jmpLbl8
      @end

      # not found at all, retry with parent
      16 /rdi /rdi :movqMemDisp8Reg
      /rdi /rdi :testqRegReg
      /retryWithParent :jnzLbl8

      @failed
      /rax /rax :xorqRegReg
      /rdx /rdx :xorqRegReg
      :retn

      @found
      8 /rdx /rax :movqMemDisp8Reg # load default activation
      8 /rdi /rdx :subqMemDisp8Reg # substract name table start
      16 /rdx :subqImm8Reg # substract name table header size
      /rdx :shrq1Reg # divide by 2 to get offset within scope

      /rdx /rcx :movqRegReg
      # rcx == entry index * 8 in scope
      # rax == entry default activation

      32 /rcx :addqImm8Reg # add scope header size
      /ecx /rdi :cmplRegMem # TODO this fails for > 4 GB scopes
      /inDataArea :jaLbl8

      /rdi /ecx :sublMemReg # substract scope length
      24 /rdi /rdi :movqMemDisp8Reg # load extension area pointer
      /rdi /rdi :testqRegReg
      /outsideExtensionArea :jzLbl8
      8 /rcx :addqImm8Reg # add extension area header length

      @inDataArea
      /rcx /rdi /rdx :movqMemIndexReg # load entry pointer
      /rax /rdx :xchgqRegReg
      /rdi /rcx :addqRegReg
      :retn

      @outsideExtensionArea
      /rax /rax :xorqRegReg
      :retn
    ] :labelResolve /internalResolve defv
  > { defv }' allocateOffsetStruct

  # TODO: link internal functions statically with relative calls
  <
    # allocate scope, expecting rdi entries
    # rdi -> expected number of entries
    # rsi -> parent scope
    # rax <- address of scope on the heap
    [
      /rsi :pushqReg
      /rdi :pushqReg
      
      # allocate name table
      4 /rdi :shlqImm8Reg
      16 /rdi :addqImm8Reg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type
      %30 7 /rax :orbImmMemDisp8

      # set fill to header size
      16 8 /rax :movqImm32MemDisp8

      /rdi :popqReg
      /rax :pushqReg # save name table on the stack

      3 /rdi :shlqImm8Reg
      32 /rdi :addqImm8Reg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type and existence of all pointers
      %26 7 /rax :orbImmMemDisp8
      8 /rax :popqMemDisp8 # reference name table
      16 /rax :popqMemDisp8 # set parent
      /rdi /rdi :xorqRegReg # zero extension
      /rdi 24 /rax :movqRegMemDisp8

      :retn
    ] /internalAllocateScope defv

    # allocate function
    # rdi -> code pointer
    # rsi -> scope pointer
    # rdx -> type pointer
    # rax <- address of function on the heap
    [
      /rdi :pushqReg
      /rdx :pushqReg

      32 /rdi :movqImmReg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type
      %50 7 /rax :orbImmMemDisp8

      /rsi 8 /rax :movqRegMemDisp8
      /rdx :popqReg
      /rdx 16 /rax :movqRegMemDisp8
      /rdi :popqReg
      /rdi 24 /rax :movqRegMemDisp8

      :retn
    ] /internalAllocateFunction defv

    # allocate code block
    # rdi -> number of code bytes
    # rax <- address of code block on heap
    [
      8 /rdi :addqImm8Reg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type
      %60 7 /rax :orbImmMemDisp8
      :retn
    ] /internalAllocateCode defv

    # allocate array, expecting rdi/8 entries
    # rdi -> expected number of entry bytes
    # rax <- address of array on the heap
    [
      8 /rdi :addqImm8Reg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type
      %70 7 /rax :orbImmMemDisp8

      :retn
    ] /internalAllocateArray defv

    # allocate string, holding rdi bytes
    # rdi -> expected number of bytes
    # rax <- address of string on the heap
    [
      /rdi :pushqReg

      /rdi :decqReg
      3 /rdi :shrqImm8Reg
      4 /rdi :addqImm8Reg
      3 /rdi :shlqImm8Reg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # set type
      %10 7 /rax :orbImmMemDisp8

      /rdx /rdx :xorqRegReg
      /rdx 8 /rax :movqRegMemDisp8
      16 /rax :popqMemDisp8

      :retn
    ] /internalAllocateString defv
  > { defv }' allocateOffsetStruct

  { ==str
    /rdi :movqImmOOBReg str string
    internalDumpErrorString /rax :movqImmReg
    /rax :callqReg
  } /outputError deff

  [
    8 /r15 :subqImm8Reg
    /r15 :popqMem
    8 /r15 :subqImm8Reg
    currentScope /rbx :movqImmReg
    /rbx /rsi :movqMemReg
    /rsi /r15 :movqRegMem
    8 /rdi :movqImmReg
    internalAllocateScope /rax :movqImmReg
    /rax :callqReg
    /rax /rbx :movqRegMem
  ] /scopingFunctionHeader defv

  [
    /r15 /rcx :movqMemReg
    currentScope /rax :movqImmReg
    /rcx /rax :movqRegMem
    8 /r15 :addqImm8Reg
    /r15 :pushqMem
    8 /r15 :addqImm8Reg
    :retn
  ] /scopingFunctionFooter defv

  [
    8 /r15 :subqImm8Reg
    /r15 :popqMem
  ] /unscopingFunctionHeader defv

  [
    /r15 :pushqMem
    8 /r15 :addqImm8Reg
    :retn
  ] /unscopingFunctionFooter defv

  {
    :quoteEncodingBuffer /rax :movqImmReg
    /rax /rdi :subqRegReg
    /rdi :pushqReg # store opcode byte count

    /rdi :decqReg
    3 /rdi :shrqImm8Reg
    /rdi :incqReg
    3 /rdi :shlqImm8Reg
    internalAllocateCode /rax :movqImmReg
    /rax :callqReg

    # rax == code block on heap

    # copy opcodes
    :quoteEncodingBuffer /rsi :movqImmReg
    8 /rax /rdi :leaqMemDisp8Reg
    /rcx :popqReg
    :reprcx :movsb
  } /allocateCodeFromEncodingBuffer deff

  { strToUTF8Bytes _ =*v len _ ==exactLength
    1 sub 8 div 4 add 8 mul ==memoryLength

    memoryLength 2147483648 lt assert

    [
      # allocate string
      memoryLength /rdi :movqImmReg
      internalAllocate /rax :movqImmReg
      /rax :callqReg

      # push string address on program stack
      /rax :pushqReg

      # set type
      7 /rax :addqImm8Reg
      %10 /rax :orbImmMem

      # clear hash value
      1 /rax :addqImm8Reg
      /rdx /rdx :xorqRegReg
      /rdx /rax :movqRegMem 

      # load exact length
      8 /rax :addqImm8Reg
      exactLength /rdx :movqImmReg
      /rdx /rax :movqRegMem 

      exactLength 0 neq {
        # load string contents
        0 exactLength 1 sub 8 div range { 8 mul ==i
          8 /rax :addqImm8Reg
          /rdx :movqImmOOBReg i _ 7 add range v 8 dearray
          /rdx /rax :movqRegMem
        } each
      } rep
    ]
  } /constStringCode deff

  <
    [
      32 { "." } rep
      " " "!" "\"" "#" "$" "%" "&" "´" "(" ")" "*" "+" "," "-" "." "/"
      /0 /1 /2 /3 /4 /5 /6 /7 /8 /9 ":" ";" "<" "=" ">" "?"
      "@" /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P
      /Q /R /S /T /U /V /W /X /Y /Z "[" "\\" "]" "^" "_"
      "`" /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p
      /q /r /s /t /u /v /w /x /y /z "{" "|" "}" "~" "."
      128 { "." } rep
    ] /ASCII defv

    { # ==addr
      [ -01 7 add 8 { _ sys .asm .peek -01 1 sub } rep -- ] { -01 256 mul add } fold
    } /peekImm64 deff

    { # ==addr
      [ -01 3 add 4 { _ sys .asm .peek -01 1 sub } rep -- ] { -01 256 mul add } fold
    } /peekImm32 deff

    { # ==addr
      sys .asm .peek
    } /peekImm8 deff

    [ /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 -01 256 div } rep -- ]
      base16digits *
      reverse |cat fold
    } /base16encode64 deff

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

    { ==objAddr
      "  int\n" sys .out .writestr
    } /intDump deff

    { ==objAddr
      "  \"" sys .out .writestr
      objAddr 16 add peekImm64 ==length
      objAddr 24 add _ length add 1 sub range peekImm8 ASCII * |cat fold sys .out .writestr
      "\"\n" sys .out .writestr
    } /stringDump deff

    { ==objAddr
      "  scope\n" sys .out .writestr

      objAddr       peekImm32
      objAddr 4 add peekImm32 16777215 band 4294967296 mul add ==length

      objAddr 8 add peekImm64 ==nameTable
      objAddr 16 add peekImm64 ==parent
      objAddr 24 add peekImm64 ==extensionArea

      nameTable 8 add peekImm64 ==nameTableEnd
      16 { _ nameTableEnd lt } {
        _ nameTable add base16encode64 ": " cat sys .out .writestr
        _ nameTable add peekImm64 stringDump
        _ 16 sub 2 div 32 add _ length lt { ==offset
            offset objAddr add peekImm64 memDump
          } { length sub 8 add ==offset
            offset extensionArea add peekImm64 memDump
          } ? *
        16 add
      } loop --
    } /scopeDump deff

    { ==objAddr
      "  nameTable\n" sys .out .writestr
    } /nameTableDump deff

    { ==objAddr
      "  extensionArea\n" sys .out .writestr
    } /extensionAreaDump deff

    { ==objAddr
      "  function\n" sys .out .writestr
    } /functionDump deff

    { ==objAddr
      "  code\n" sys .out .writestr
    } /codeDump deff

    { ==addr
      [
        "  "
        addr base16encode64
        ": "
        # the perl interpreter does not like full 64bit numbers and converts them into floats
        addr 4 add peekImm32 _ ==heapValueB base16encode32
        addr       peekImm32 _ ==heapValueA base16encode32
        " "
        [ [ heapValueA heapValueB ] { 4 { _ 256 mod -01 256 div } rep -- } each ] ASCII * 8 dearray
        "\n"
      ] |cat fold sys .out .writestr
    } /memDump deff

    { ==objAddr
      "Object at " objAddr base16encode64 cat " ----------\n" cat sys .out .writestr
      objAddr       peekImm32
      objAddr 4 add peekImm32 16777215 band 4294967296 mul
        add 8 div ==length
      0 length 1 sub range { 8 mul objAddr add memDump } each

      objAddr 7 add peekImm8 16 div
      [
        |intDump |stringDump |scopeDump |nameTableDump |extensionAreaDump |functionDump |codeDump |die
        |die |die |die |die |die |die |die |die
      ] *
      objAddr -01*
      "^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" sys .out .writestr
    } /heapDump deff

    {
      :mainStack .base :STACKSIZE add ==stackEnd
      "Stack ------------\n" sys .out .writestr
      :mainStack .base peekImm64 ==addr
      addr stackEnd gt { [ -01 stackEnd ] die } rep # Stack corrupted

      { addr stackEnd lt } {
        [
          addr base16encode64 ": "
          addr peekImm64 ==value
          value base16encode64
          "\n"
        ] |cat fold sys .out .writestr

        value 105553116266496 ge value 123145302310912 lt and {
          value       peekImm32
          value 4 add peekImm32 16777215 band 4294967296 mul
            add 8 div ==length
          0 length 1 sub range { 8 mul value add memDump } each
        } rep
        addr 8 add =addr
      } loop
      "^^^^^^^^^^^^^^^^^^\n" sys .out .writestr
    } /stackDump

    {
      currentScope peekImm64 heapDump
    } /globalScopeDump
  > -- 2 |deff rep
> /assemblerLibrary defv

# vim: syn=elymas