level1/46_os_face.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 : (on-bye)  ... ;
   8
   9 code: (N-BYE)  ( exitcode -- )
  10   push  TOS
  11   mov   eax,252  ;; sys_exit_group
  12   mov   ebx,TOS
  13   syscall
  14   pop   TOS
  15   mov   eax,1
  16   mov   ebx,TOS
  17   syscall
  18 endcode
  19 (noreturn)
  20
  21
  22 : bye  ( -- ) (on-bye) 0 (n-bye) ; (noreturn)
  23 : n-bye  ( n -- ) >r (on-bye) r> (n-bye) ; (noreturn)
  24
  25
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 vocabulary OS
  28 voc-set-active OS
  29
  30
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;; dynamic?
  33 $if URFORTH_DYNAMIC_BINARY
  34 code: DLCLOSE  ( handle-or-0 -- )
  35   jecxz .fucked
  36   ;; push registers
  37   push  EIP
  38   push  ERP
  39   ;; call
  40   push  TOS
  41   call  [elfimp_dlclose]
  42   add   esp,4   ;; remove args
  43   pop   ERP
  44   pop   EIP
  45 .fucked:
  46   pop   TOS
  47   urnext
  48 endcode
  49
  50 code: (DLOPEN-ASCIIZ)  ( addr -- handle-or-0 )
  51   jecxz .fucked
  52   ;; save registers
  53   push  EIP
  54   push  ERP
  55   ;; call function
  56   ;;ld    eax,1+256+8   ;; RTLD_LAZY+RTLD_GLOBAL+RTLD_DEEPBIND
  57   push  1+256+8   ;; RTLD_LAZY+RTLD_GLOBAL+RTLD_DEEPBIND
  58   push  TOS
  59   call  [elfimp_dlopen]
  60   add   esp,4*2       ;; remove arguments
  61   ;; restore registers
  62   pop   ERP
  63   pop   EIP
  64   ld    TOS,eax
  65 .fucked:
  66   urnext
  67 endcode
  68
  69 : DLOPEN  ( addr count -- handle-or-0 )
  70   ensure-asciiz >r
  71   (DLOPEN-ASCIIZ)
  72   r> free-asciiz
  73 ;
  74
  75 code: (DLSYM-ASCIIZ)  ( addr handle -- address-or-0 )
  76   pop   edi
  77   test  edi,edi
  78   jr    z,.fucked
  79   ;; save registers
  80   push  EIP
  81   push  ERP
  82   ;; call function
  83   push  edi
  84   push  TOS
  85   call  [elfimp_dlsym]
  86   add   esp,4*2       ;; remove arguments
  87   ;; restore registers
  88   pop   ERP
  89   pop   EIP
  90   ld    TOS,eax
  91   urnext
  92 .fucked:
  93   xor   TOS,TOS
  94   urnext
  95 endcode
  96
  97 : DLSYM  ( addr count handle -- handle-or-0 )
  98   nrot ensure-asciiz >r
  99   swap (DLSYM-ASCIIZ)
 100   r> free-asciiz
 101 ;
 102
 103 $constant "RTLD-DEFAULT" 0
 104 $constant "RTLD-NEXT" -1
 105
 106 ;; call a C function
 107 ;; negative or zero argcount means "pop nothing"
 108 code: CINVOKE ( ... addr argcount -- res )
 109   pop   eax
 110   pushr TOS
 111   pushr EIP
 112   call  eax
 113   mov   TOS,eax
 114   popr EIP
 115   popr eax
 116   cp    eax,0
 117   jr    le,@f
 118   lea   esp,[esp+eax*4]
 119 @@:
 120   urnext
 121 endcode
 122 $endif
 123
 124
 125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126 code: (FUNLINK-ASCIIZ)  ( addr -- errcode-or-0 )
 127   jecxz .fucked
 128   ld    ebx,TOS
 129   ld    eax,10
 130   syscall
 131   ld    TOS,eax
 132   urnext
 133 .fucked:
 134   ld    TOS,-666
 135   urnext
 136 endcode
 137
 138 : UNLINK  ( addr count -- errcode-or-0 )
 139   ensure-asciiz >r
 140   (FUNLINK-ASCIIZ)
 141   r> free-asciiz
 142 ;
 143
 144
 145 code: (FRENAME-ASCIIZ)  ( addrold addrnew -- errcode-or-0 )
 146   pop   ebx
 147   jecxz .fucked
 148   test  ebx,ebx
 149   jr    z,.fucked
 150   ld    eax,38
 151   syscall
 152   ld    TOS,eax
 153   urnext
 154 .fucked:
 155   ld    TOS,-666
 156   urnext
 157 endcode
 158
 159 : RENAME  ( addrold countold addrnew countnew -- errcode-or-0 )
 160   ensure-asciiz >r
 161   nrot ['] ensure-asciiz forth:catch ?dup if r> free-asciiz forth:throw endif >r
 162   swap (FRENAME-ASCIIZ)
 163   r> free-asciiz r> free-asciiz
 164 ;
 165
 166
 167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 168 code: CLOSE  ( fd -- flag )
 169   ;; syscall
 170   ld    eax,6
 171   ld    ebx,TOS
 172   syscall
 173   ld    TOS,eax
 174   urnext
 175 endcode
 176
 177 code: (OPEN-ASCIIZ)  ( addr flags crperm -- fd-or-minusone )
 178   pop   edx   ;; flags
 179   pop   edi   ;; addr
 180   ld    eax,TOS
 181   ;; EAX: crperm
 182   ;; EDX: flags (r, w, r/w, flags)
 183   ;; EDI: addr
 184   test  edi,edi
 185   jr    z,.fucked
 186   ld    ebx,edi
 187   ld    ecx,edx
 188   ld    edx,eax
 189   ld    eax,5
 190   syscall
 191   ld    TOS,eax
 192   urnext
 193 .fucked:
 194   ld    TOS,-666
 195   urnext
 196 endcode
 197
 198 : OPEN  ( addr count flags crperm -- handle-or-<0 )
 199   2swap ensure-asciiz >r nrot
 200   (OPEN-ASCIIZ)
 201   r> free-asciiz
 202 ;
 203
 204 code: (READ)  ( addr count fd -- count )
 205   pop   edx   ;; count
 206   pop   edi   ;; addr
 207   ld    eax,3
 208   ld    ebx,TOS
 209   ld    ecx,edi
 210   syscall
 211   ld    TOS,eax
 212   urnext
 213 endcode
 214
 215 code: (WRITE)  ( addr count fd -- count )
 216   pop   edx   ;; count
 217   pop   edi   ;; addr
 218   ld    eax,4
 219   ld    ebx,TOS
 220   ld    ecx,edi
 221   syscall
 222   ld    TOS,eax
 223   urnext
 224 endcode
 225
 226 : (do-rw)  ( addr count fd cfa -- count )
 227   begin 2over 2over execute dup -4 ( EINTR) = while drop repeat
 228   >r 2drop 2drop r>
 229 ; (hidden)
 230
 231 : read   ( addr count fd -- count/err )  ['] (read) (do-rw) ;
 232 : write  ( addr count fd -- count/err )  ['] (write) (do-rw) ;
 233
 234 code: LSEEK  ( ofs whence fd -- res )
 235   ld    ebx,TOS
 236   pop   edx
 237   pop   ecx
 238   ld    eax,19
 239   syscall
 240   ld    TOS,eax
 241   urnext
 242 endcode
 243
 244 code: LLSEEK  ( ofslo ofshi whence fd -- ofslo ofshi res )
 245   ld    ebx,TOS      ;; fd
 246   pop   edi          ;; whence
 247   push  EIP
 248   push  ERP
 249   ld    ecx,[esp+8]  ;; lo
 250   ld    edx,[esp+12] ;; hi
 251   lea   esi,[esp+8]  ;; put position there
 252   ld    eax,140
 253   syscall
 254   pop   ERP
 255   pop   EIP
 256   ld    TOS,eax
 257   ;; swap result
 258   ld    edx,[esp+0]
 259   xchg  edx,[esp+4]
 260   ld    [esp+0],edx
 261   urnext
 262 endcode
 263
 264 code: FSYNC  ( fd -- res )
 265   ld    ebx,TOS      ;; fd
 266   ld    eax,118
 267   syscall
 268   ld    TOS,eax
 269   urnext
 270 endcode
 271
 272 code: FSYNC-DATA  ( fd -- res )
 273   ld    ebx,TOS      ;; fd
 274   ld    eax,148
 275   syscall
 276   ld    TOS,eax
 277   urnext
 278 endcode
 279
 280 code: FTRUNC  ( size fd -- res )
 281   ld    ebx,TOS
 282   pop   ecx
 283   ld    eax,93
 284   syscall
 285   ld    TOS,eax
 286   urnext
 287 endcode
 288
 289 code: FTRUNC64  ( sizelo sizehi fd -- res )
 290   ld    ebx,TOS      ;; fd
 291   pop   edx
 292   pop   ecx
 293   ld    eax,194
 294   syscall
 295   ld    TOS,eax
 296   urnext
 297 endcode
 298
 299
 300
 301 $constant "O-RDONLY" 0
 302 $constant "O-WRONLY" 1
 303 $constant "O-RDWR"   2
 304
 305 $constant "O-CREAT"     0x000040  ;; 0100
 306 $constant "O-EXCL"      0x000080  ;; 0200
 307 $constant "O-NOCTTY"    0x000100  ;; 0400
 308 $constant "O-TRUNC"     0x000200  ;; 01000
 309 $constant "O-APPEND"    0x000400  ;; 02000
 310 $constant "O-NONBLOCK"  0x000800  ;; 04000
 311 $constant "O-DSYNC"     0x001000  ;; 010000
 312 $constant "O-SYNC"      0x101000  ;; 04010000
 313 $constant "O-RSYNC"     0x101000  ;; 04010000
 314 $constant "O-DIRECTORY" 0x010000  ;; 0200000
 315 $constant "O-NOFOLLOW"  0x020000  ;; 0400000
 316 $constant "O-CLOEXEC"   0x080000  ;; 02000000
 317
 318 $constant "O-ASYNC"     0x002000  ;; 020000
 319 $constant "O-DIRECT"    0x004000  ;; 040000
 320 $constant "O-LARGEFILE" 0x008000  ;; 0100000
 321 $constant "O-NOATIME"   0x040000  ;; 01000000
 322 $constant "O-PATH"      0x200000  ;; 010000000
 323 $constant "O-TMPFILE"   0x410000  ;; 020200000
 324 $constant "O-NDELAY"    0x000800  ;; 04000
 325
 326 $constant "O-CREATE-FLAGS-NOMODE" 0x000240
 327 $constant "O-CREATE-WRONLY-FLAGS" 0x000241
 328 $constant "O-CREATE-MODE-NORMAL"  0x1A4
 329
 330 $constant "SEEK-SET" 0
 331 $constant "SEEK-CUR" 1
 332 $constant "SEEK-END" 2
 333
 334 $constant "S-ISUID" 0x800  ;; 04000
 335 $constant "S-ISGID" 0x400  ;; 02000
 336 $constant "S-ISVTX" 0x200  ;; 01000
 337 $constant "S-IRUSR" 0x100  ;; 0400
 338 $constant "S-IWUSR" 0x080  ;; 0200
 339 $constant "S-IXUSR" 0x040  ;; 0100
 340 $constant "S-IRWXU" 0x1c0  ;; 0700
 341 $constant "S-IRGRP" 0x020  ;; 0040
 342 $constant "S-IWGRP" 0x010  ;; 0020
 343 $constant "S-IXGRP" 0x008  ;; 0010
 344 $constant "S-IRWXG" 0x038  ;; 0070
 345 $constant "S-IROTH" 0x004  ;; 0004
 346 $constant "S-IWOTH" 0x002  ;; 0002
 347 $constant "S-IXOTH" 0x001  ;; 0001
 348 $constant "S-IRWXO" 0x007  ;; 0007
 349
 350
 351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 352 $constant "STAT.dev"         0  ;; rd 1
 353 $constant "STAT.ino"         4  ;; rd 1
 354 $constant "STAT.mode"        8  ;; rw 1
 355 $constant "STAT.nlink"      10  ;; rw 1
 356 $constant "STAT.uid"        12  ;; rw 1
 357 $constant "STAT.gid"        14  ;; rw 1
 358 $constant "STAT.rdev"       16  ;; rd 1
 359 $constant "STAT.size"       20  ;; rd 1
 360 $constant "STAT.blksize"    24  ;; rd 1
 361 $constant "STAT.blocks"     28  ;; rd 1
 362 $constant "STAT.atime"      32  ;; rd 1
 363 $constant "STAT.atime_nsec" 36  ;; rd 1
 364 $constant "STAT.mtime"      40  ;; rd 1
 365 $constant "STAT.mtime_nsec" 44  ;; rd 1
 366 $constant "STAT.ctime"      48  ;; rd 1
 367 $constant "STAT.ctime_nsec" 52  ;; rd 1
 368 ;; $constant "STAT.__unused4"     56  ;; rd 1
 369 ;; $constant "STAT.__unused5"     60  ;; rd 1
 370 $constant "#STAT"      64
 371
 372 $constant "STAT64.dev"         0  ;; rq 1, rb 4
 373 $constant "STAT64._ino"       12  ;; rd 1
 374 $constant "STAT64.mode"       16  ;; rd 1
 375 $constant "STAT64.nlink"      20  ;; rd 1
 376 $constant "STAT64.uid"        24  ;; rd 1
 377 $constant "STAT64.gid"        28  ;; rd 1
 378 $constant "STAT64.rdev"       32  ;; rq 1, rb 4
 379 $constant "STAT64.size"       44  ;; rq 1
 380 $constant "STAT64.blksize"    52  ;; rd 1
 381 $constant "STAT64.blocks"     56  ;; rq 1
 382 $constant "STAT64.atime"      64  ;; rd 1
 383 $constant "STAT64.atime_nsec" 68  ;; rd 1
 384 $constant "STAT64.mtime"      72  ;; rd 1
 385 $constant "STAT64.mtime_nsec" 76  ;; rd 1
 386 $constant "STAT64.ctime"      80  ;; rd 1
 387 $constant "STAT64.ctime_nsec" 84  ;; rd 1
 388 $constant "STAT64.ino"        88  ;; rq 1
 389 $constant "#STAT64"           96
 390
 391
 392 $constant "S-IFMT"   0o0170000
 393
 394 $constant "S-IFDIR"  0o0040000
 395 $constant "S-IFCHR"  0o0020000
 396 $constant "S-IFBLK"  0o0060000
 397 $constant "S-IFREG"  0o0100000
 398 $constant "S-IFIFO"  0o0010000
 399 $constant "S-IFLNK"  0o0120000
 400 $constant "S-IFSOCK" 0o0140000
 401
 402
 403 \ statbuf should be #STAT bytes
 404 code: (STAT)  ( nameaddrz statbuf -- errcode )
 405   pop   ebx
 406   ld    eax,106
 407   syscall
 408   ld    TOS,eax
 409   urnext
 410 endcode
 411
 412 \ statbuf should be #STAT64 bytes
 413 code: (STAT64)  ( nameaddrz statbuf -- errcode )
 414   pop   ebx
 415   ld    eax,195
 416   syscall
 417   ld    TOS,eax
 418   urnext
 419 endcode
 420
 421
 422 : STAT  ( nameaddr namecount statbuf -- errcode )  nrot ensure-asciiz >r swap (stat) r> free-asciiz ;
 423 : STAT64  ( nameaddr namecount statbuf -- errcode )  nrot ensure-asciiz >r swap (stat64) r> free-asciiz ;
 424
 425 : STAT-MODE  ( addr count -- mode true // false )
 426   #stat ralloca dup >r stat if false else r@ stat.mode + w@ true endif
 427   rdrop #stat rdealloca
 428 ;
 429
 430 : STAT-SIZE  ( addr count -- size true // false )
 431   #stat ralloca dup >r stat if false else r@ stat.size + @ true endif
 432   rdrop #stat rdealloca
 433 ;
 434
 435 : STAT-SIZE64  ( addr count -- sizelo sizehi true // false )
 436   #stat64 ralloca dup >r stat64 if false else r@ stat64.size + 2@le true endif
 437   rdrop #stat64 rdealloca
 438 ;
 439
 440 ;; is regular file?
 441 : FILE?  ( addr count -- flag )  stat-mode if S-IFREG and notnot else false endif ;
 442 ;; is directory?
 443 : DIR?  ( addr count -- flag )  stat-mode if S-IFDIR and notnot else false endif ;
 444
 445
 446 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 447 ;; get seconds since epoch
 448 code: TIME  ( -- seconds )
 449   push  TOS
 450   ld    eax,13   ;; sys_time
 451   xor   ebx,ebx  ;; result only in eax
 452   syscall
 453   ld    TOS,eax
 454   urnext
 455 endcode
 456
 457 $constant "CLOCK-REALTIME"            0
 458 $constant "CLOCK-MONOTONIC"           1
 459 $constant "CLOCK-PROCESS-CPUTIME-ID"  2
 460 $constant "CLOCK-THREAD-CPUTIME-ID"   3
 461 $constant "CLOCK-MONOTONIC-RAW"       4
 462 $constant "CLOCK-REALTIME-COARSE"     5
 463 $constant "CLOCK-MONOTONIC-COARSE"    6
 464 $constant "CLOCK-BOOTTIME"            7
 465 $constant "CLOCK-REALTIME-ALARM"      8
 466 $constant "CLOCK-BOOTTIME-ALARM"      9
 467
 468 $constant "NANOSECONDS/SECOND"  1000000000
 469 $constant "NANOSECONDS/MSEC"    1000000
 470
 471 ;; get seconds and nanoseconds (since some random starting point)
 472 code: CLOCK-GETTIME  ( clockid -- seconds nanoseconds )
 473   sub   esp,4+4  ;; timespec
 474   ld    eax,265  ;; sys_clock_gettime
 475   ld    ebx,TOS  ;; clockid
 476   ld    ecx,esp
 477   syscall
 478   test  eax,eax
 479   pop   eax
 480   pop   TOS
 481   jr    z,.done
 482   xor   TOS,TOS
 483   xor   eax,eax
 484 .done:
 485   push  eax
 486   urnext
 487 endcode
 488
 489
 490 code: NANOSLEEP  ( seconds nanoseconds -- errcode )
 491   xchg  TOS,dword [esp]
 492   push  TOS
 493   ;; [esp+0]: timespec
 494   ld    eax,162
 495   ld    ebx,esp
 496   ld    ecx,ebx  ;; fill the same struct
 497   syscall
 498   add   esp,4+4
 499   ld    TOS,eax
 500   urnext
 501 endcode
 502
 503 : MSSLEEP  ( msecs -- )
 504   dup +if 1000 u/mod swap nanoseconds/msec u* nanosleep drop
 505   else drop
 506   endif
 507 ;
 508
 509
 510 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 511 $value "(GETTICKCOUNT-START-SECS)" 0
 512 (hidden)
 513
 514 ..: forth:(startup-init)  ( -- )
 515   clock-monotonic clock-gettime drop
 516   dup 1 > if 1- endif
 517   to (gettickcount-start-secs)
 518 ;..
 519
 520
 521 : GETTICKCOUNT  ( -- msecs )
 522   clock-monotonic clock-gettime
 523   nanoseconds/msec u/
 524   swap (gettickcount-start-secs) - 1000 u*
 525   +
 526 ;
 527
 528
 529 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 530 code: GET-PID  ( -- pid )
 531   push  TOS
 532   ld    eax,20
 533   syscall
 534   ld    TOS,eax
 535   urnext
 536 endcode
 537
 538 code: GET-TID  ( -- tid )
 539   push  TOS
 540   ld    eax,224
 541   syscall
 542   ld    TOS,eax
 543   urnext
 544 endcode
 545
 546
 547 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 548 ;; request and reply
 549 $constant "POLL-IN"     0x0001  ;; read ready
 550 $constant "POLL-PRI"    0x0002  ;; some exceptional condition
 551 $constant "POLL-OUT"    0x0004  ;; write ready
 552 ;; reply only
 553 $constant "POLL-ERR"    0x0008  ;; error, or read end of the pipe closed (set for write end)
 554 $constant "POLL-HUP"    0x0010  ;; hangup/connection closed (there still may be data to read)
 555 $constant "POLL-NVAL"   0x0020  ;; invalid fd
 556
 557 $constant "POLL-RDNORM" 0x0040  ;; man says that this is the same as "POLL-IN"
 558 $constant "POLL-RDBAND" 0x0080  ;; priority data can be read
 559 $constant "POLL-WRNORM" 0x0100  ;; man says that this is the same as "POLL-OUT"
 560 $constant "POLL-WRBAND" 0x0200  ;; priority data can be written
 561
 562 $constant "POLL-MSG"    0x0400  ;; man says that is is accepted, but does nothing
 563 $constant "POLL-RDHUP"  0x2000  ;; stream socket peer closed connection, or shut down writing half of connection
 564
 565 ;; special timeouts
 566 $constant "POLL-INFINITE" -1
 567 $constant "POLL-NOWAIT" 0
 568
 569 $constant "#POLLFD" 8
 570
 571 code: POLLFD.FD  ( addr -- addr+0 )
 572   urnext
 573 endcode
 574
 575 code: POLLFD.EVENTS  ( addr -- addr+4 )
 576   add   TOS,4
 577   urnext
 578 endcode
 579
 580 code: POLLFD.REVENTS  ( addr -- addr+6 )
 581   add   TOS,6
 582   urnext
 583 endcode
 584
 585 ;; returs -errno or number of records changed
 586 code: POLL  ( pollfdarrptr count mstime -- res )
 587   ld    edx,TOS
 588   pop   ecx
 589   pop   ebx
 590   ld    eax,168
 591   syscall
 592   ld    TOS,eax
 593   urnext
 594 endcode
 595
 596
 597 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 598 $constant "MAP-FILE"            0x0000_0000
 599 $constant "MAP-SHARED"          0x0000_0001
 600 $constant "MAP-PRIVATE"         0x0000_0002
 601 $constant "MAP-SHARED_VALIDATE" 0x0000_0003
 602 $constant "MAP-TYPE"            0x0000_000f
 603 $constant "MAP-FIXED"           0x0000_0010
 604 $constant "MAP-ANON"            0x0000_0020
 605 $constant "MAP-ANONYMOUS"       0x0000_0020
 606 $constant "MAP-NORESERVE"       0x0000_4000
 607 $constant "MAP-GROWSDOWN"       0x0000_0100
 608 $constant "MAP-DENYWRITE"       0x0000_0800
 609 $constant "MAP-EXECUTABLE"      0x0000_1000
 610 $constant "MAP-LOCKED"          0x0000_2000
 611 $constant "MAP-POPULATE"        0x0000_8000
 612 $constant "MAP-NONBLOCK"        0x0001_0000
 613 $constant "MAP-STACK"           0x0002_0000
 614 $constant "MAP-HUGETLB"         0x0004_0000
 615 $constant "MAP-SYNC"            0x0008_0000
 616 $constant "MAP-FIXED_NOREPLACE" 0x0010_0000
 617
 618 $constant "PROT-NONE"  0
 619 $constant "PROT-READ"  1
 620 $constant "PROT-WRITE" 2
 621 $constant "PROT-EXEC"  4
 622 $constant "PROT-R/W"   3
 623 $constant "PROT-RWX"   7
 624
 625 $constant "PROT-GROWSDOWN" 0x01000000
 626 $constant "PROT-GROWSUP"   0x02000000
 627
 628
 629 code: MMAP  ( size protflags -- addr true // error false )
 630   ld    edx,TOS          ;; protflags
 631   pop   ecx              ;; size
 632   push  EIP
 633   push  ERP
 634   ld    esi,0x0000_0022  ;; we always doing anon private alloc
 635   xor   ebp,ebp          ;; offset, it is ignored, but why not
 636   xor   edi,edi          ;; fd (-1)
 637   dec   edi
 638   xor   ebx,ebx          ;; address
 639   ld    eax,192
 640   syscall
 641   pop   ERP
 642   pop   EIP
 643   push  eax
 644   cp    eax,0xffff_f000
 645   setc  cl
 646   movzx TOS,cl
 647   urnext
 648 endcode
 649
 650 code: MMAP-FD  ( size protflags offset fd -- addr true // error false )
 651   push  EIP
 652   push  ERP
 653   ld    edi,TOS          ;; fd
 654   ld    esi,0x0000_0001  ;; map file, shared
 655   ld    ebp,[esp+8]      ;; offset
 656   ld    edx,[esp+12]     ;; protflags
 657   ld    ecx,[esp+16]     ;; size
 658   xor   ebx,ebx          ;; address
 659   ld    eax,192
 660   syscall
 661   pop   ERP
 662   pop   EIP
 663   add   esp,4*3
 664   push  eax
 665   cp    eax,0xffff_f000
 666   setc  cl
 667   movzx TOS,cl
 668   urnext
 669 endcode
 670
 671 code: MUNMAP  ( addr size -- res )
 672   pop   ebx
 673   ld    eax,91
 674   syscall
 675   ld    TOS,eax
 676   urnext
 677 endcode
 678
 679 ;; use "MMAP-ERROR?" to check for errors
 680 ;; can move block
 681 code: MREMAP  ( addr oldsize newsize -- newaddr true // error false )
 682   ld    edx,TOS
 683   pop   ecx
 684   pop   ebx
 685   push  EIP
 686   ld    eax,163
 687   ld    esi,1    ;; MREMAP_MAYMOVE
 688   xor   edi,edi  ;; new addres; doesn't matter
 689   syscall
 690   pop   EIP
 691   push  eax
 692   cp    eax,0xffff_f000
 693   setc  cl
 694   movzx TOS,cl
 695   urnext
 696 endcode
 697
 698 code: MPROTECT  ( addr size protflags -- res )
 699   ld    edx,TOS
 700   pop   ecx
 701   pop   ebx
 702   ld    eax,125
 703   syscall
 704   ld    TOS,eax
 705   urnext
 706 endcode
 707
 708 code: MLOCK  ( addr size -- res )
 709   pop   ebx
 710   ld    eax,150
 711   syscall
 712   ld    TOS,eax
 713   urnext
 714 endcode
 715
 716 code: MUNLOCK  ( addr size -- res )
 717   pop   ebx
 718   ld    eax,151
 719   syscall
 720   ld    TOS,eax
 721   urnext
 722 endcode
 723
 724 code: MUNLOCK-ALL  ( -- res )
 725   push  TOS
 726   ld    eax,153
 727   syscall
 728   ld    TOS,eax
 729   urnext
 730 endcode
 731
 732
 733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 734 $if URFORTH_TLS_TYPE = URFORTH_TLS_TYPE_FS
 735
 736 $constant "CSIGNAL"              0x000000ff
 737 $constant "CLONE-VM"             0x00000100
 738 $constant "CLONE-FS"             0x00000200
 739 $constant "CLONE-FILES"          0x00000400
 740 $constant "CLONE-SIGHAND"        0x00000800
 741 $constant "CLONE-PIDFD"          0x00001000
 742 $constant "CLONE-PTRACE"         0x00002000
 743 $constant "CLONE-VFORK"          0x00004000
 744 $constant "CLONE-PARENT"         0x00008000
 745 $constant "CLONE-THREAD"         0x00010000
 746 $constant "CLONE-NEWNS"          0x00020000
 747 $constant "CLONE-SYSVSEM"        0x00040000
 748 $constant "CLONE-SETTLS"         0x00080000
 749 $constant "CLONE-PARENT-SETTID"  0x00100000
 750 $constant "CLONE-CHILD-CLEARTID" 0x00200000
 751 $constant "CLONE-DETACHED"       0x00400000
 752 $constant "CLONE-UNTRACED"       0x00800000
 753 $constant "CLONE-CHILD-SETTID"   0x01000000
 754 $constant "CLONE-NEWCGROUP"      0x02000000
 755 $constant "CLONE-NEWUTS"         0x04000000
 756 $constant "CLONE-NEWIPC"         0x08000000
 757 $constant "CLONE-NEWUSER"        0x10000000
 758 $constant "CLONE-NEWPID"         0x20000000
 759 $constant "CLONE-NEWNET"         0x40000000
 760 $constant "CLONE-IO"             0x80000000
 761
 762 ;; settidptr: for CLONE-PARENT_SETTID (edx)
 763 ;; tlsptr: tls info pointer for CLONE-SETTLS (esi)
 764 ;; childtidptr: for CLONE-CHILD-CLEARTID and CLONE-CHILD-SETTID
 765 code: CLONE  ( cfa sp rp flags tlsptr settidptr childtidptr -- err )
 766   push  TOS
 767   push  ERP
 768   push  EIP
 769   ;; [esp+8]: childtidptr
 770   ;; [esp+12]: settidptr
 771   ;; [esp+16]: tlsptr
 772   ;; [esp+20]: flags
 773   ;; [esp+24]: rp
 774   ;; [esp+28]: sp
 775   ;; [esp+32]: cfa
 776   ;; this works like this:
 777   ;;   setup new ERP
 778   ;;   push cfa to new ERP
 779   ;;   call clone
 780   ;;   on error, exit with error code
 781   ;;   if EAX is 0: we're in child
 782   ;;     setup ts to tlsptr (if there is any)
 783   ;;     get cfa from ERP, jump to it
 784   ;;   if EAX is !0: we're in parent
 785   ;;     restore Exx, drop args, return EAX
 786   ;; setup new ERP
 787   ld    ERP,[esp+24]  ;; rp
 788   ;; push cfa to new ERP
 789   ld    eax,[esp+32]  ;; cfa
 790   pushr eax
 791   ;; save tls entry index (we cannot access the stack in child)
 792   xor   eax,eax
 793   test  dword [esp+20],0x00080000 ;; CLONE-SETTLS
 794   jr    z,@f
 795   ld    eax,[esp+16] ;; tlsptr
 796   test  eax,eax
 797   jr    z,@f
 798   ld    eax,[eax]    ;; entry index
 799 @@:
 800   pushr eax
 801   ld    eax,120      ;; sys_clone
 802   ld    ebx,[esp+20] ;; flags
 803   ld    ecx,[esp+28] ;; sp
 804   ld    edx,[esp+12] ;; settidptr
 805   ld    esi,[esp+16] ;; tlsptr
 806   ld    edi,[esp+8]  ;; childtidptr
 807   test  esi,esi
 808   syscall
 809   ;; error?
 810   cp    eax,0xffff_f000
 811   jr    nc,.error
 812   ld    dword [pfa "(mt-active?)"],1
 813   ;; child?
 814   test  eax,eax
 815   jr    nz,.parent
 816   ;; setup TS
 817   popr  eax
 818   test  eax,eax
 819   jr    z,@f
 820   lea   eax,[eax*8+3]
 821   ld    ts,eax
 822 @@:
 823   ;; we're in child: get cfa, jump there
 824   popr  eax
 825   ;; thread stack contains two args
 826   sub   esp,4
 827   pop   TOS
 828   jp    eax
 829 .parent:
 830   ;; we're in parent
 831 .error:
 832   pop   EIP
 833   pop   ERP
 834   add   esp,4*7
 835   ld    TOS,eax
 836   urnext
 837 endcode
 838
 839 code: (trd-exit)  ( code -- )
 840   ;; free tls
 841   ld    ebp,TOS
 842   ld    ebx,gs:[ua_ofs_baseaddr]
 843   ld    ecx,gs:[ua_ofs_fullsize]
 844   ld    eax,91   ;; unmap
 845   syscall
 846   ld    eax,1    ;; exit
 847   ld    ebx,ebp  ;; let's hope it survived
 848   syscall
 849 endcode
 850 (hidden) (noreturn)
 851 $endif
 852
 853 code: EXIT-THREAD  ( exitcode -- )
 854   mov   eax,1
 855   mov   ebx,TOS
 856   syscall
 857 endcode
 858 (noreturn)
 859
 860
 861 voc-set-active FORTH
 862
 863 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 864 alias OS:GETTICKCOUNT MS@
 865
 866
 867 ;; returns current address if the request is invalid
 868 code: (BRK)  ( newaddr -- newaddr )
 869   ld    eax,45  ;; brk
 870   ld    ebx,TOS ;; new address
 871   syscall
 872   ld    TOS,eax
 873   urnext
 874 endcode
 875
 876 : (BRK-HERE)  ( -- curraddr )
 877   0 (brk)
 878 ;
 879
 880 ;; throws OOM error
 881 : BRK-ALLOC  ( size -- addr )
 882   dup 0< err-out-of-memory ?error
 883   (brk-here)  ( size addr )
 884   swap ?dup if  ( addr size )
 885     over + dup (brk)
 886     u< err-out-of-memory ?error
 887   endif
 888 ;