From fdd6dbf870747bd02f3a3ce6523dcc2c32880acb Mon Sep 17 00:00:00 2001 From: Drahflow Date: Wed, 28 Aug 2013 14:29:13 +0200 Subject: More functions in the library --- compiler/elymasGlobalStr.ey | 35 + compiler/elymasGlobalSys.ey | 16 +- compiler/elymasGlobalSysAsm.ey | 17 + compiler/standard.ey | 2 +- compiler/standardClient.ey | 1370 ++++++++++++++++++++-------------------- 5 files changed, 754 insertions(+), 686 deletions(-) diff --git a/compiler/elymasGlobalStr.ey b/compiler/elymasGlobalStr.ey index 3376049..e48407b 100644 --- a/compiler/elymasGlobalStr.ey +++ b/compiler/elymasGlobalStr.ey @@ -98,6 +98,41 @@ /rbx :pushqReg :retn ]] /eypostfix defv + + # produce a string from an integer array specifying its bytes + # 0 -> array of integers + # 0 <- the same bytes as a string + [[ + /rbx :popqReg + + /rsi :popqReg + /rsi :pushqReg + /rsi /edi :movlMemReg # load array length + 3 /rdi :shrqImm8Reg + /rdi :decqReg + /rdi :pushqReg + + ::internalAllocateString /rax :movqImmReg + /rax :callqReg + + /rcx :popqReg # number of characters to copy + /rsi :popqReg + 8 /rsi :addqImm8Reg # move rsi to first array entry + /rax :pushqReg # store target string on stack + 24 /rax :addqImm8Reg # move rax to first string byte + + @copyByte + /rsi /rdx :movqMemReg # load object pointer + 8 /rdx /rdx :movqMemDisp8Reg # load integer value + /dl /rax :movbRegMem + + 8 /rsi :addqImm8Reg + /rax :incqReg + /copyByte :loopLbl8 + + /rbx :pushqReg + :retn + ]] /eyfromArray defv > _ ==globalFunctions { defv }' ::allocateOffsetStruct [ diff --git a/compiler/elymasGlobalSys.ey b/compiler/elymasGlobalSys.ey index 01ca564..2f2b763 100644 --- a/compiler/elymasGlobalSys.ey +++ b/compiler/elymasGlobalSys.ey @@ -3,14 +3,28 @@ < # handle an identifier in the current scope according to current quote level - # 0 -> identifier to handle + # 0 -> scope to execute identifier in + # 1 -> identifier to handle + # 0 <- scope after execution [[ 8 /r15 :subqImm8Reg /r15 :popqMem + + ::currentScope /rax :movqImmReg + 8 /r15 :subqImm8Reg + /rax /rcx :movqMemReg + /rcx /r15 :movqRegMem + /rax :popqMem # load scope from argument internalExecuteIdentifier /rax :movqImmReg /rax :callqReg + ::currentScope /rax :movqImmReg + /rax :pushqMem + /r15 /rcx :movqMemReg + /rcx /rax :movqRegMem # restore old scope + 8 /r15 :addqImm8Reg + /r15 :pushqMem 8 /r15 :addqImm8Reg :retn diff --git a/compiler/elymasGlobalSysAsm.ey b/compiler/elymasGlobalSysAsm.ey index 425bada..8a5499c 100644 --- a/compiler/elymasGlobalSysAsm.ey +++ b/compiler/elymasGlobalSysAsm.ey @@ -183,6 +183,23 @@ :retn ]] /eyglobalAllocSize defv + # get raw object address from object + # 0 -> object + # 0 <- address of the object + [[ + /rbx :popqReg + + # allocate return integer + ::internalAllocateInteger /rax :movqImmReg + /rax :callqReg + + 8 /rax :popqMemDisp8 + /rax :pushqReg + + /rbx :pushqReg + :retn + ]] /eyrawAddress defv + # get raw code execution address from function object # 0 -> function object # 0 <- address of first instruction diff --git a/compiler/standard.ey b/compiler/standard.ey index 0c92d47..caf9b0e 100644 --- a/compiler/standard.ey +++ b/compiler/standard.ey @@ -61,7 +61,7 @@ { _ =*conds len ==max 0 ==i { i max lt } { - i conds { i 1 add conds * max =i } { } ? * + i conds * { i 1 add conds * max =i } { } ? * i 2 add =i } loop } /conds deffd diff --git a/compiler/standardClient.ey b/compiler/standardClient.ey index a05999f..6e3c19e 100644 --- a/compiler/standardClient.ey +++ b/compiler/standardClient.ey @@ -1,760 +1,774 @@ -< # sys extensions - # TODO: handle EINTR correctly +## regex support +# ideas taken from http://swtch.com/~rsc/regexp/regexp3.html +{ + 0 ==:MATCH 1 ==:TERM 2 ==:JUMP 3 ==:SPLIT 4 ==:SAVE 5 ==:FIRST 6 ==:LAST - 0 _ ==:RDONLY - 1 _ ==:WRONLY - 2 _ ==:RDWR - bor bor ==:RWMASK + { ==b ==a [ + [ SPLIT 1 a len 1 add ] # FIXME this should be "2 add"?! + a _ len dearray + [ JUMP b len ] + b _ len dearray + ] } /alternative deffst - 64 ==:OCREAT - 1024 ==:OAPPEND + |cat /sequence deffd - 1 ==:PROTREAD - 2 ==:PROTWRITE - 4 ==:PROTEXEC + { ==?a [ # TODO measure separate + implementation performance impact + [ JUMP a len 1 add ] + a _ len dearray + [ SPLIT 1 a len neg ] + ] } /star deffst - 2 ==:MAPPRIVATE - 32 ==:MAPANONYMOUS - - 0 ==:READ - 1 ==:WRITE - 2 ==:OPEN - 3 ==:CLOSE + { ==?p [ + [ TERM p ] + ] } /terminal deffst - 9 ==:MMAP - 11 ==:MUNMAP - 60 ==:EXIT + { ==?i ==?a [ + [ SAVE i 2 mul ] + a _ len dearray + [ SAVE i 2 mul 1 add ] + ] } /capture deffst - { ==code - code 0 0 0 0 0 EXIT sys .asm .syscall - "exit failed" die - } /exit sys .deff + { [ ] } /empty deffd - { < ==?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 - { flags OCREAT bor =flags } /creating deff - { flags OAPPEND bor =flags } /appending 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 + { ==?str + str len 0 eq { + 1 neg + } { + 0 str * + } ? * + } /head deffd - { # 0777 = 511 - 1 neg RDONLY 511 makefile - } /file sys .deff + { 1 -01 str .postfix } /tail deffd - 0 RDONLY 0 makefile /in sys .defv - 1 WRONLY 0 makefile /out sys .defv - 2 WRONLY 0 makefile /err sys .defv + { 0 -01 * -101 head eq } "^" deffd + { deffd }' /install deffst + [ "(" ")" "[" "]" "-" "|" "^" "*" "+" "." "$" "\\" ] { ==?c + { _ head 0 c * eq } "^" c cat install + } each - < # 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 + { # "(parse) re: " -101 cat dump - ==base - reqSize ==size + seq ==?a + ^| { + tail parse ==?b + a b alternative =a + } rep + a + } /parse deffst - { - base size 0 0 0 0 MUNMAP sys .asm .syscall -- - 0 lt { "munmap failed" die } rep - } =*free - > - } /allocAt sys .asm .deff + { # "(seq) re: " -101 cat dump - { - 0 sys .asm .allocAt - } /alloc sys .asm .deff - > -- + empty _ ==?a + ==?l - < # sys .typed extensions + { # "(seq loop) re: " -101 cat dump + _ head 1 neg eq -01 + ^| -01 + ^) -01 + -0321 or or not + } { + [ { ^* } { + l star =l + tail + } { ^+ } { + l l star sequence =l + tail + } { 1 } { + a l sequence =a + atom =l + } ] conds + } loop + a l sequence + } /seq deffst - # 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 + 0 ==?currentCapture + + { # "(atom) re: " -101 cat dump + empty ==?a - 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 + [ { ^( } { + tail parse currentCapture capture =a + currentCapture 1 add =currentCapture + ^) not { ") expected" die } rep + tail + } { ^[ } { + tail + ^^ { + tail chars =*nset + { nset not }' ==?set + ^] not { "] expected" die } rep + tail + }' { + chars ==?set + ^] not { "] expected" die } rep + tail + }' ? * + set terminal =a + } { ^. } { + { -- 1 }" terminal =a + tail + } { ^^ } { + [ [ FIRST ] ] =a + tail + } { ^$ } { + [ [ LAST ] ] =a + tail + } { ^\ } { + tail + [ { ^d } { + { _ 0 "0" * ge -01 0 "9" * le and }" terminal =a + tail + } { ^\ } { + { 0 "\\" * eq }" terminal =a + tail + } { ^. } { + { 0 "." * eq }" terminal =a + tail + } { ^n } { + { 0 "\n" * eq }" terminal =a + tail + } { 1 } { + "invalid character '" "' after \\ in regex" -120 cat cat die + } ] conds + } { 1 } { + _ head { eq }_ terminal =a + tail + } ] conds - { [ -01 typeStackInternal ] } /typeStack deff + # "(atom end) re: " -101 cat dump + a + } /atom deffst - { -- 0 } /isVariableType deff + { # "(chars) re: " -101 cat dump + ^] { + tail chars2 =*s + { _ s -01 0 "]" * eq or }' ==?set + }' { + chars2 ==?set + }' ? * + set + } /chars deffst - { ==t - t len 3 neq { "complex execution type non-triple" die } rep + { # "(chars2) re: " -101 cat dump + ^- { + tail chars2 =*s + { _ s -01 0 "-" * eq or }' ==?set + }' { + charsR ==?set + }' ? * + set + } /chars2 deffst - 2 t * 1 t * ge - } /isIterableType deff - - { =*a =*b - [ - 0 a sys .typed .type 0 b sys .typed .type neq - { 0 } + { # "(charsR) re: " -101 cat dump + charsN ==?set + { ^] not } { + set =*s1 + charsN =*s2 + { _ s1 -01 s2 or }' =set + } loop + set + } /charsR deffst - 0 a sys .typed .type 0 neq - { "type equality only implemented for ints" die } + { # "(charsN) re: " -101 cat dump + _ head ==?start + ^\ { + tail + [ { ^\ } { + 0 "\\" * =start + } { ^n } { + 0 "\n" * =start + } { 1 } { + "invalid character '" "' after \\ in regex" -120 cat cat die + } ] conds + } rep + tail + ^- { + tail + _ head ==?end + ^\ { + tail + [ { ^\ } { + 0 "\\" * =end + } { ^n } { + 0 "\n" * =end + } { 1 } { + "invalid character '" "' after \\ in regex" -120 cat cat die + } ] conds + } rep + tail + { _ start ge -01 end le and }' ==?set + }' { + { start eq }' ==?set + }' ? * + set + } /charsN deffst - 0 b sys .typed .type 0 neq - { "type equality only implemented for ints" die } + { 0 -01 * }" /threadGetPC deffd + { 1 -01 * }" /threadGetCaptures deffd - 0 a 0 b neq { 0 } - 1 { 1 } - ] conds - } /typeEqual deff + { [ + 0 # pc + [ currentCapture { 0 0 } rep ] # captures + ] } /newThread deff - { ==earlierType ==laterType - [ - earlierType laterType typeEqual - { earlierType 1 } + { #==thread ==newpc + [ -021 threadGetCaptures ] + }" /cloneThread deffd - # TODO: maybe handle structs here one day (or move the whole affair into - # a real compilation stage - 0 earlierType * sys .typed .type 0 neq - { 0 } + { #==thread ==newpc + [ -0201 threadGetCaptures _ len dearray ] ] + }" /fullCloneThread deffd - # Who came first determines iteration range - 2 earlierType * 1 neg neq - { earlierType 1 } + |add /origadd deffd - # But if only the later one defines a range, take that one - 2 laterType * 1 neg neq - { laterType 1 } + # TODO think about implementation efficiency + { < ==maxSize + 0 ==size + [ maxSize { 0 }" rep ] =*get + [ maxSize { 1 }" rep ] =*pcFree - # General integers go-iterate iff they binary and results in non-zero - 0 earlierType * 0 laterType * band 0 neq - { earlierType 1 } + { # ==thread + _ threadGetPC pcFree { + _ size |get =[] + 0 -01 threadGetPC |pcFree =[] + size 1 origadd =size + }" { -- }" ? * + }' /add deffst - 1 - { 0 } - ] conds - } /commonIterationType deff + { + 0 =size + [ maxSize { 1 }" rep ] =pcFree + }' /clear deffst + > } /threadList deffd - { ==arr - 0 - } /getLoopStart deff + { ==prog ==string + 0 ==position + string len ==maxPosition + 0 ==done + 0 ==matched - { ==arr - arr len eq - } /isLoopEnd deff + prog len _ threadList ==clist + threadList ==nlist - { ==arr - 1 add - } /doLoopStep deff + newThread _ ==thread clist .add - # 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 + 0 ==pc + { } =*code - # Phase 1 - 0 inputs len range reverse { - # print "Analyzing arg: %d" - inputs * typeStack ==?formalTypeStack - _ ==?c typeStack ==?concreteTypeStack - # "Type-Stack: %d" Dumper($concreteTypeStack) die + [ + { # MATCH + 1 =matched + clist .clear + }" { # TERM + position maxPosition lt { + position string * 1 code * { pc 1 add thread cloneThread nlist .add }" rep + }" rep + }" { # JUMP + pc 1 code add thread cloneThread clist .add + }" { # SPLIT + pc 1 code add thread cloneThread clist .add + pc 2 code add thread cloneThread clist .add + }" { # SAVE + pc 1 add thread fullCloneThread + position 1 code -2102 threadGetCaptures =[] + clist .add + }" { # FIRST + position 0 eq { pc 1 add thread cloneThread clist .add }" rep + }" { # LAST + position maxPosition eq { pc 1 add thread cloneThread clist .add }" rep + }" + ] =*codeSemantics - 0 ==?bestViewPortSize - concreteTypeStack len 1 add ==?bestViewPortMatch + 0 ==i + { position maxPosition le done not and }" { + 0 =i + { i clist .size lt done not and }" { + i clist .get _ =thread + threadGetPC _ =pc + prog * =code + 0 code codeSemantics * + i 1 add =i + }" loop - # "Formal Type Stack: @$formalTypeStack\n" print - # " Type Stack: @$concreteTypeStack\n" print + clist nlist =clist =nlist + nlist .clear + position 1 add =position + }" loop - 1 neg concreteTypeStack * isVariableType { - 1 concreteTypeStack len 1 add range { ==?viewPortSize - [ 0 viewPortSize range { concreteTypeStack * } each ] ==?typeViewPort # explicit each here - # "@$formalTypeStack vs. @$concreteTypeStack\n" print + matched { + currentCapture ==i + { i } { i 1 sub =i + string + i 2 mul thread threadGetCaptures * _ ==start -01 str .postfix + i 2 mul 1 add thread threadGetCaptures * start sub -01 str .inplacePrefix + } loop + } rep + matched + } /execute deffst - formalTypeStack concreteTypeStack typeMismatchCount ==?viewPortMatch # FIXME this line seems fishy - viewPortMatch bestViewPortMatch lt { - viewPortSize =bestViewPortSize - viewPortMatch =bestViewPortMatch - } rep - } each - } { - concreteTypeStack len =bestViewPortSize - 0 =bestViewPortMatch - } ? * + parse ==prog -- + [ + [ SPLIT 3 1 ] + [ TERM { -- 1 }" ] + [ JUMP 2 neg ] + prog _ len dearray + [ MATCH ] + ] =prog + { prog execute } +} /enregex deffd - # 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 - } ? * +{ + quoted { + _ sys .typed .type 1 eq { + enregex + } { |enregex "*" | } ? * + } { enregex * } ? * +} /regex defq - [ c ] concreteArgs cat =concreteArgs - } each +< # sys extensions + # TODO: handle EINTR correctly - # "Viewport Offsets: @viewPortOffset\n" print + 0 _ ==:RDONLY + 1 _ ==:WRONLY + 2 _ ==:RDWR + bor bor ==:RWMASK - # Phase 2, - [ - 0 viewPortOffset len range { ==?i - i concreteArgs * typeStack ==?remaining - [ 0 i viewPortOffset * range { remaining * } each ] # explicit each here - } each - ] ==?toBeAbstractedTypes + 64 ==:OCREAT + 1024 ==:OAPPEND - "toBeAbstractedTypes: " dump - toBeAbstractedTypes dump + 1 ==:PROTREAD + 2 ==:PROTWRITE + 4 ==:PROTEXEC - [ 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 - 0 concreteArgs len range { ==?i - i concreteArgs * sys .typed .type _ dump - i inputs * sys .typed .type _ dump - neq { "invalid input type at argument index " dump i dump "" die } rep - } each - * - } { - [ ] ==?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 + 2 ==:MAPPRIVATE + 32 ==:MAPANONYMOUS + + 0 ==:READ + 1 ==:WRITE + 2 ==:OPEN + 3 ==:CLOSE - 0 toBeAbstractedTypes len 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 + 9 ==:MMAP + 11 ==:MUNMAP + 60 ==:EXIT - 0 i range reverse { ==?j - j toBeAbstractedTypes * len not not { - 0 j toBeAbstractedTypes * * type commonIterationType # -> - { =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 + { ==code + code 0 0 0 0 0 EXIT sys .asm .syscall + "exit failed" die + } /exit sys .deff - 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 + { < ==?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 + { flags OCREAT bor =flags } /creating deff + { flags OAPPEND bor =flags } /appending 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 + { =*f "" ==buffer + { + buffer 4096 read cat =buffer # FIXME interpreter API should also have .read defined as returning string + buffer "" streq not + } { + { + buffer "([^\\n]*)\\n" regex + } { + _ len 1 add buffer str .postfix =buffer + f } loop - } each + } loop + } /eachLine deff + > > -- } /makefile deff - "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 + |makefile /fdToFile sys .deff - [ 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 + { # 0777 = 511 + 1 neg RDONLY 511 makefile + } /file sys .deff - i loopedOver doLoopStep =i - } loop + 0 RDONLY 0 makefile /in sys .defv + 1 WRONLY 0 makefile /out sys .defv + 2 WRONLY 0 makefile /err sys .defv - results - # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]]; - # FIXME the undef can be determined - } { - { ==?v - stage { ==?i - v i concreteArgs * * i concreteArgs =[] - } each + < # 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 - 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 + ==base + reqSize ==size - concreteArgs stageCalls argTypes loops unravel + { + base size 0 0 0 0 MUNMAP sys .asm .syscall -- + 0 lt { "munmap failed" die } rep + } =*free + > + } /allocAt sys .asm .deff - "execution complete" dump - } ? * - } /execute sys .typed .deff + { + 0 sys .asm .allocAt + } /alloc sys .asm .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 deffd + < # sys .typed extensions - { ==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 - invalid # name table - invalid # extension area - { "" } # 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 deffd + # 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 - # dump top stack element to sys .err - { 0 dumpIndented } -> -- /dump deffd + 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 -## regex support -# ideas taken from http://swtch.com/~rsc/regexp/regexp3.html -{ - 0 ==:MATCH 1 ==:TERM 2 ==:JUMP 3 ==:SPLIT 4 ==:SAVE 5 ==:FIRST 6 ==:LAST + { [ -01 typeStackInternal ] } /typeStack deff - { ==b ==a [ - [ SPLIT 1 a len 1 add ] # FIXME this should be "2 add"?! - a _ len dearray - [ JUMP b len ] - b _ len dearray - ] } /alternative deffst + { -- 0 } /isVariableType deff - |cat /sequence deffd + { ==t + t len 3 neq { "complex execution type non-triple" die } rep - { ==?a [ # TODO measure separate + implementation performance impact - [ JUMP a len 1 add ] - a _ len dearray - [ SPLIT 1 a len neg ] - ] } /star deffst + 2 t * 1 t * ge + } /isIterableType deff - { ==?p [ - [ TERM p ] - ] } /terminal deffst + { =*a =*b + [ + { 0 a sys .typed .type 0 b sys .typed .type neq } + { 0 } - { ==?i ==?a [ - [ SAVE i 2 mul ] - a _ len dearray - [ SAVE i 2 mul 1 add ] - ] } /capture deffst + { 0 a sys .typed .type 0 neq } + { "type equality only implemented for ints" die } - { [ ] } /empty deffd + { 0 b sys .typed .type 0 neq } + { "type equality only implemented for ints" die } - { ==?str - str len 0 eq { - 1 neg - } { - 0 str * - } ? * - } /head deffd + { 0 a 0 b neq } { 0 } + { 1 } { 1 } + ] conds + } /typeEqual deff - { 1 -01 str .postfix } /tail deffd + { ==earlierType ==laterType + [ + earlierType laterType typeEqual + { earlierType 1 } - { 0 -01 * -101 head eq } "^" deffd - { deffd }' /install deffst - [ "(" ")" "[" "]" "-" "|" "^" "*" "+" "." "$" "\\" ] { ==?c - { _ head 0 c * eq } "^" c cat install - } each + # TODO: maybe handle structs here one day (or move the whole affair into + # a real compilation stage + { 0 earlierType * sys .typed .type 0 neq } + { 0 } - { # "(parse) re: " -101 cat dump + # Who came first determines iteration range + { 2 earlierType * 1 neg neq } + { earlierType 1 } - seq ==?a - ^| { - tail parse ==?b - a b alternative =a - } rep - a - } /parse deffst + # But if only the later one defines a range, take that one + { 2 laterType * 1 neg neq } + { laterType 1 } - { # "(seq) re: " -101 cat dump + # General integers go-iterate iff they binary and results in non-zero + { 0 earlierType * 0 laterType * band 0 neq } + { earlierType 1 } - empty _ ==?a - ==?l + { 1 } + { 0 } + ] conds + } /commonIterationType deff - { # "(seq loop) re: " -101 cat dump - _ head 1 neg eq -01 - ^| -01 - ^) -01 - -0321 or or not - } { - { ^* } { - l star =l - tail - } { ^+ } { - l l star sequence =l - tail - } { - a l sequence =a - atom =l - } ifthenelse ifthenelse * - } loop - a l sequence - } /seq deffst + { ==arr + 0 + } /getLoopStart deff - { ==e ==t =*i - { i t e ? * } - } /ifthenelse deffd + { ==arr + arr len eq + } /isLoopEnd deff - 0 ==?currentCapture - - { # "(atom) re: " -101 cat dump - empty ==?a + { ==arr + 1 add + } /doLoopStep deff - { ^( } { - tail parse currentCapture capture =a - currentCapture 1 add =currentCapture - ^) not { ") expected" die } rep - tail - } { ^[ } { - tail - ^^ { - tail chars =*nset - { nset not }' ==?set - ^] not { "] expected" die } rep - tail - }' { - chars ==?set - ^] not { "] expected" die } rep - tail - }' ? * - set terminal =a - } { ^. } { - { -- 1 }" terminal =a - tail - } { ^^ } { - [ [ FIRST ] ] =a - tail - } { ^$ } { - [ [ LAST ] ] =a - tail - } { ^\ } { - tail - { ^d } { - { _ 0 "0" * ge -01 0 "9" * le and }" terminal =a - tail - } { ^\ } { - { 0 "\\" * eq }" terminal =a - tail - } { ^n } { - { 0 "\n" * eq }" terminal =a - tail - } { - "invalid character '" "' after \\ in regex" -120 cat cat die - } ifthenelse ifthenelse ifthenelse * - } { - _ head { eq }_ terminal =a - tail - } ifthenelse ifthenelse ifthenelse ifthenelse ifthenelse ifthenelse * + # 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 - # "(atom end) re: " -101 cat dump - a - } /atom deffst + # Phase 1 + 0 inputs len range reverse { + # print "Analyzing arg: %d" + inputs * typeStack ==?formalTypeStack + _ ==?c typeStack ==?concreteTypeStack + # "Type-Stack: %d" Dumper($concreteTypeStack) die - { # "(chars) re: " -101 cat dump - ^] { - tail chars2 =*s - { _ s -01 0 "]" * eq or }' ==?set - }' { - chars2 ==?set - }' ? * - set - } /chars deffst + 0 ==?bestViewPortSize + concreteTypeStack len 1 add ==?bestViewPortMatch - { # "(chars2) re: " -101 cat dump - ^- { - tail chars2 =*s - { _ s -01 0 "-" * eq or }' ==?set - }' { - charsR ==?set - }' ? * - set - } /chars2 deffst + # "Formal Type Stack: @$formalTypeStack\n" print + # " Type Stack: @$concreteTypeStack\n" print - { # "(charsR) re: " -101 cat dump - charsN ==?set - { ^] not } { - set =*s1 - charsN =*s2 - { _ s1 -01 s2 or }' =set - } loop - set - } /charsR deffst + 1 neg concreteTypeStack * isVariableType { + 1 concreteTypeStack len 1 add range { ==?viewPortSize + [ 0 viewPortSize range { concreteTypeStack * } each ] ==?typeViewPort # explicit each here + # "@$formalTypeStack vs. @$concreteTypeStack\n" print - { # "(charsN) re: " -101 cat dump - _ head ==?start - ^\ { - tail - { ^\ } { - 0 "\\" * =start - } { ^n } { - 0 "\n" * =start - } { - "invalid character '" "' after \\ in regex" -120 cat cat die - } ifthenelse ifthenelse * - } rep - tail - ^- { - tail - _ head ==?end - ^\ { - tail - { ^\ } { - 0 "\\" * =end - } { ^n } { - 0 "\n" * =end + formalTypeStack concreteTypeStack typeMismatchCount ==?viewPortMatch # FIXME this line seems fishy + viewPortMatch bestViewPortMatch lt { + viewPortSize =bestViewPortSize + viewPortMatch =bestViewPortMatch + } rep + } each } { - "invalid character '" "' after \\ in regex" -120 cat cat die - } ifthenelse ifthenelse * - } rep - tail - { _ start ge -01 end le and }' ==?set - }' { - { start eq }' ==?set - }' ? * - set - } /charsN deffst + 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 - { 0 -01 * }" /threadGetPC deffd - { 1 -01 * }" /threadGetCaptures deffd + # "Viewport Offsets: @viewPortOffset\n" print - { [ - 0 # pc - [ currentCapture { 0 0 } rep ] # captures - ] } /newThread deff + # Phase 2, + [ + 0 viewPortOffset len range { ==?i + i concreteArgs * typeStack ==?remaining + [ 0 i viewPortOffset * range { remaining * } each ] # explicit each here + } each + ] ==?toBeAbstractedTypes - { #==thread ==newpc - [ -021 threadGetCaptures ] - }" /cloneThread deffd + "toBeAbstractedTypes: " dump + toBeAbstractedTypes dump - { #==thread ==newpc - [ -0201 threadGetCaptures _ len dearray ] ] - }" /fullCloneThread deffd + [ 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 + 0 concreteArgs len range { ==?i + i concreteArgs * sys .typed .type _ dump + i inputs * sys .typed .type _ dump + neq { "invalid input type at argument index " dump i dump "" die } rep + } each + * + } { + [ ] ==?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 - |add /origadd deffd + 0 toBeAbstractedTypes len 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 - # TODO think about implementation efficiency - { < ==maxSize - 0 ==size - [ maxSize { 0 }" rep ] =*get - [ maxSize { 1 }" rep ] =*pcFree + 0 i range reverse { ==?j + j toBeAbstractedTypes * len not not { + 0 j toBeAbstractedTypes * * type commonIterationType # -> + { =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 - { # ==thread - _ threadGetPC pcFree { - _ size |get =[] - 0 -01 threadGetPC |pcFree =[] - size 1 origadd =size - }" { -- }" ? * - }' /add deffst + 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 - { - 0 =size - [ maxSize { 1 }" rep ] =pcFree - }' /clear deffst - > } /threadList deffd + "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 - { ==prog ==string - 0 ==position - string len ==maxPosition - 0 ==done - 0 ==matched + [ 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 - prog len _ threadList ==clist - threadList ==nlist + i loopedOver doLoopStep =i + } loop - newThread _ ==thread clist .add + results + # push @$data, [\@results, ['array', '[]', [['range', 0, $#results]], [undef]]]; + # FIXME the undef can be determined + } { + { ==?v + stage { ==?i + v i concreteArgs * * i concreteArgs =[] + } each - 0 ==pc - { } =*code + 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 - [ - { # MATCH - 1 =matched - clist .clear - }" { # TERM - position maxPosition lt { - position string * 1 code * { pc 1 add thread cloneThread nlist .add }" rep - }" rep - }" { # JUMP - pc 1 code add thread cloneThread clist .add - }" { # SPLIT - pc 1 code add thread cloneThread clist .add - pc 2 code add thread cloneThread clist .add - }" { # SAVE - pc 1 add thread fullCloneThread - position 1 code -2102 threadGetCaptures =[] - clist .add - }" { # FIRST - position 0 eq { pc 1 add thread cloneThread clist .add }" rep - }" { # LAST - position maxPosition eq { pc 1 add thread cloneThread clist .add }" rep - }" - ] =*codeSemantics + concreteArgs stageCalls argTypes loops unravel - 0 ==i - { position maxPosition le done not and }" { - 0 =i - { i clist .size lt done not and }" { - i clist .get _ =thread - threadGetPC _ =pc - prog * =code - 0 code codeSemantics * - i 1 add =i - }" loop + "execution complete" dump + } ? * + } /execute sys .typed .deff + > -- +> -- - clist nlist =clist =nlist - nlist .clear - position 1 add =position - }" loop +# 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 - matched { - currentCapture ==i - { i } { i 1 sub =i - string - i 2 mul thread threadGetCaptures * _ ==start -01 str .postfix - i 2 mul 1 add thread threadGetCaptures * start sub -01 str .inplacePrefix - } loop - } rep - matched - } /execute deffst + { + [ -01 8 { _ 256 mod base16digits * -01 256 div } rep -- ] + reverse |cat fold + } /base16encode64 deffd - parse ==prog -- - [ - [ SPLIT 3 1 ] - [ TERM { -- 1 }" ] - [ JUMP 2 neg ] - prog _ len dearray - [ MATCH ] - ] =prog - { prog execute } -} /enregex deffd + { ==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 + { "" cat sys .err .writeall } + invalid # name table + invalid # extension area + { "" cat sys .err .writeall } + 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 deffd -{ - quoted { - _ sys .typed .type 1 eq { - enregex - } { |enregex "*" | } ? * - } { enregex * } ? * -} /regex defq + # dump top stack element to sys .err + { 0 dumpIndented } +> -- /dump deffd { ==filename # ==?f (left on the stack and executed from sys .asm .programStart) sys .asm .patchProgramStart ==frozenAllocationCount @@ -955,35 +969,23 @@ out .close } /freeze sys .deff -{ .value sys .executeIdentifier }' -< - /TOKID defvd # weird scoping so executeIdentifier is executed in global scope - { .value elymas .base10decode } /TOKINT defvd - { .value } /TOKSTR defvd +# no long-term stack use here as the executed program uses it as well +{ scope + { ==currentScope ==input + { .value currentScope sys .executeIdentifier =currentScope } /TOKID defvd + { .value elymas .base10decode } /TOKINT defvd + { .value } /TOKSTR defvd - # no long-term stack use here as the executed program uses it as well - { ==input - "" ==buffer { - buffer 4096 input .read cat =buffer # FIXME interpreter API should also have .read defined as returning string - buffer "" streq not - } { - { - buffer "([^\\n]*)\\n" regex - } { ==line - line len 1 add buffer str .postfix =buffer - line TOKINT TOKSTR TOKID elymas .tokenize { - _ .handle - } each - } loop - } loop - } /executeFile deffd - - { # ==?filename - sys .file -0010 .open - executeFile - .close - } -> -- /include deffd + TOKINT TOKSTR TOKID elymas .tokenize { _ .handle } each + } input .eachLine + } * +}" /includeFile deffd + +{ # ==?filename + sys .file -0010 .open + includeFile + .close +}" /include deffd # vim: syn=elymas -- cgit v1.2.3