diff options
Diffstat (limited to 'src/roms/SLOF/slof')
114 files changed, 20529 insertions, 0 deletions
diff --git a/src/roms/SLOF/slof/Makefile.inc b/src/roms/SLOF/slof/Makefile.inc new file mode 100644 index 0000000..8ad3337 --- /dev/null +++ b/src/roms/SLOF/slof/Makefile.inc @@ -0,0 +1,171 @@ +# ***************************************************************************** +# * Copyright (c) 2004, 2008 IBM Corporation +# * All rights reserved. +# * This program and the accompanying materials +# * are made available under the terms of the BSD License +# * which accompanies this distribution, and is available at +# * http://www.opensource.org/licenses/bsd-license.php +# * +# * Contributors: +# * IBM Corporation - initial implementation +# ****************************************************************************/ + +# Before including this Makefile, you should specify the following variables +# in your Makefile: +# - INCLCMNDIR : Points to the common include directory +# - INCLCMNDIR : Points to the board specific include directory +# - SLOFCMNDIR : Points to the common SLOF directory +# - SLOFBRDDIR : Points to the board specific SLOF directory +# - LLFWCMNDIR : Points to the common LLFW directory +# - LLFWBRDDIR : Points to the board specific LLFW directory + +# Set LLFW directories (should normally be set from parent Makefile): +TOPBRDDIR ?= $(shell cd .. && pwd) +LLFWBRDDIR ?= $(TOPBRDDIR)/llfw +LLFWCMNDIR ?= $(SLOFCMNDIR:%/slof=%/llfw) +INCLBRDDIR ?= $(TOPBRDDIR)/include + + +CPPFLAGS += -I. -I$(INCLCMNDIR) -I$(INCLBRDDIR) -I$(INCLCMNDIR)/$(CPUARCH) +CFLAGS = -DTARG=$(TARG) -static -Wall -W -std=gnu99 \ + -O2 -fomit-frame-pointer -msoft-float $(FLAG) $(CPUARCHDEF) \ + -fno-stack-protector -fno-strict-aliasing +ASFLAGS = -Wa,-mpower4 -Wa,-mregnames $(FLAG) $(CPUARCHDEF) + +LDFLAGS += -static -nostdlib -Wl,-q,-n + +ifneq ($(TARG),unix) +CFLAGS += -nostdinc -fno-builtin +CPPFLAGS += -I$(LIBCMNDIR)/libc/include +SLOF_LIBS += $(LIBCMNDIR)/libc.a +endif + +DICT = $(SLOFCMNDIR)/prim.in $(SLOFCMNDIR)/engine.in \ + $(BOARD_SLOF_IN) $(SLOFCMNDIR)/$(TARG).in + +# Source code files with automatic dependencies: +SLOF_BUILD_SRCS = paflof.c helpers.c allocator.c + +# Flags for pre-processing Forth code with CPP: +FPPFLAGS = -nostdinc -traditional-cpp -undef -P -C $(FLAG) +FPPINCLUDES ?= -I$(SLOFBRDDIR) -I$(SLOFCMNDIR)/fs + +# Rules for pre-processing Forth code: +# - Use CPP for pre-processing #include directives +# - Use sed to strip all white spaces at the beginning of a line +# - Use sed to remove all lines that only contain a comment +# - Use sed to remove all empty lines from the file +%.fsi: %.fs +ifeq ($(V),1) + printf "\t[FPP]\t%s\n" `basename "$@"` +endif + rm -f $@ + cpp $(FPPFLAGS) $(FPPINCLUDES) $< > $@.tmp + sed -e 's/^[ ]*//' < $@.tmp \ + | sed -e '/^\\[ ]/d' \ + | sed -e '/^([ ][^)]*[ ])[ ]*$$/d' \ + | sed -e '/^$$/d' > $@ + rm -f $@.tmp + + +OF.o: OF.fsi + $(LD) -o $@ -r -bbinary $< + + +dict.xt: $(DICT) $(SLOFCMNDIR)/ref.pl + cat $(DICT) | perl $(SLOFCMNDIR)/ref.pl -s $(CELLSIZE) > dict.xt + +ifdef BOARD_SLOF_CODE +board.code: $(BOARD_SLOF_CODE) + cat $(BOARD_SLOF_CODE) > $@ +else +board.code: + echo > $@ +endif + +paflof: $(SLOFCMNDIR)/OF.lds $(SLOFCMNDIR)/ofw.o paflof.o $(SLOFCMNDIR)/entry.o \ + helpers.o allocator.o romfs.o version.o OF.o nvramlog.o $(LLFWBRDDIR)/board_io.o \ + $(LLFWBRDDIR)/io_generic_lib.o $(SLOF_LIBS) + $(CC) -T$(SLOFCMNDIR)/OF.lds $(SLOFCMNDIR)/ofw.o version.o paflof.o helpers.o allocator.o \ + $(SLOFCMNDIR)/entry.o romfs.o OF.o nvramlog.o $(LLFWBRDDIR)/board_io.o \ + $(LLFWBRDDIR)/io_generic_lib.o $(LDFLAGS) $(SLOF_LIBS) -o $@ + #save a copy of paflof before stripping + @cp $@ $@.unstripped + $(STRIP) --strip-unneeded $@ + +paflof.o: board.code dict.xt + $(CC) $(CPPFLAGS) $(CFLAGS) -c -o $@ $(SLOFCMNDIR)/paflof.c + +helpers.o: + $(CC) $(CPPFLAGS) $(CFLAGS) -c -o $@ $(SLOFCMNDIR)/helpers.c + +allocator.o: + $(CC) $(CPPFLAGS) $(CFLAGS) -c -o $@ $(SLOFCMNDIR)/allocator.c + +$(SLOFCMNDIR)/xvect.bin: $(SLOFCMNDIR)/lowmem.o + $(CC) $(LDFLAGS) -Wl,--oformat,binary -Ttext=0x100 -o xvect.bin.tmp $< + dd if=xvect.bin.tmp of=$(SLOFCMNDIR)/xvect.bin bs=256 skip=1 2>/dev/null + rm -f xvect.bin.tmp + +romfs.o: + $(CC) $(CPPFLAGS) $(ASFLAGS) -c -o $@ $(LLFWCMNDIR)/romfs.S + +nvramlog.o: + $(CC) $(CPPFLAGS) $(ASFLAGS) -c -o $@ $(LLFWCMNDIR)/nvramlog.S + +checkpoint.o: + $(CC) $(CPPFLAGS) $(ASFLAGS) -c -o $@ $(LLFWCMNDIR)/checkpoint.S + +$(LLFWBRDDIR)/board_io.o: + $(MAKE) -C $(LLFWBRDDIR) board_io.o + +$(LLFWBRDDIR)/io_generic_lib.o: + $(MAKE) -C $(LLFWBRDDIR) io_generic_lib.o + +default-font.o: $(SLOFCMNDIR)/default-font.c + $(CC) $(CPPFLAGS) $< -c -o default-font.o + +$(SLOFBRDDIR)/default-font.bin: default-font.o + $(OBJCOPY) -Obinary default-font.o $@ + +.PHONY : create_OF.ffs clean_slof distclean_slof depend + + +# Create OF.ffs automatically from file list in OF_FFS_FILES variable. +# We have to use absolute path names there, so we have to use `pwd` to +# find them out: +create_OF_ffs: + rm -f OF.ffs + @for i in $(OF_FFS_FILES) ; do \ + CURRENTDIR=`pwd` ; cd `dirname $$i` ; \ + DIRNAME=`pwd` ; cd $$CURRENTDIR ; \ + echo `basename $$i | sed -e s/\.fsi/\.fs/` \ + $$DIRNAME/`basename $$i` 0 0 >> OF.ffs ; \ + done + + +# Targets for cleaning up: +clean_slof: + rm -f $(SLOFCMNDIR)/*.o $(SLOFCMNDIR)/*.bin $(SLOFCMNDIR)/*.elf + rm -f dict.xt board.code paflof paflof.unstripped default-font.bin + rm -f $(filter %.fsi,$(OF_FFS_FILES)) + +distclean_slof: clean_slof + rm -f Makefile.dep + + +# Rules for creating the dependency file: +depend: + rm -f Makefile.dep + $(MAKE) Makefile.dep + +Makefile.dep: Makefile $(SLOFCMNDIR)/Makefile.inc OF.fs + $(CC) -M -MG $(CPPFLAGS) $(CFLAGS) $(SLOF_BUILD_SRCS:%=$(SLOFCMNDIR)/%) > Makefile.dep + cpp -M -MG $(FPPFLAGS) $(FPPINCLUDES) -MT OF.fsi OF.fs >> Makefile.dep + for i in $(filter %.fsi,$(OF_FFS_FILES)) ; do \ + cpp -M -MG $(FPPFLAGS) $(FPPINCLUDES) -MT $$i \ + `echo $$i | sed -e 's/\.fsi/\.fs/'` >> Makefile.dep ; \ + done + +# Include dependency file if available: +-include Makefile.dep diff --git a/src/roms/SLOF/slof/OF.lds b/src/roms/SLOF/slof/OF.lds new file mode 100644 index 0000000..5f8b2b1 --- /dev/null +++ b/src/roms/SLOF/slof/OF.lds @@ -0,0 +1,65 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +OUTPUT_FORMAT("elf64-powerpc", "elf64-powerpc", "elf64-powerpc") +OUTPUT_ARCH(powerpc:common64) +ENTRY(_start_OF) + + +SECTIONS +{ + . = 0x0E100100; + _start_OF = .; + .slof.loader : { *(.slof.loader) } + . = ALIGN(0x100); + _slof_text = .; + .text : { *(.entry_text) *(.text) } = 0x60000000 + _slof_text_end = .; + . = ALIGN(8); + _slof_text_size = (_slof_text_end - _slof_text); + + . = ALIGN(0x100); + .opd : + { + _slof_data = .; + *(.opd) + } + . = ALIGN(8); + .got : + { + *(.got .toc) + } + + .data : { + *(.rodata .rodata.*) + *(.data .data.*) + *(.note.gnu.build-id) + } + + .comment : { *(.comment) } + .branch_lt : { *(.branch_lt) } + + . = ALIGN(8); + _slof_data_end = .; + _slof_data_size = (_slof_data_end - _slof_data); + + .bss : + { + _slof_bss = .; + *(*COM* .bss .sbss .gnu.linkonce.b.*) + _slof_bss_end = .; + } + _slof_bss_size = (_slof_bss_end - _slof_bss); + + . = ALIGN(0x1000); + the_mem = .; +} diff --git a/src/roms/SLOF/slof/allocator.c b/src/roms/SLOF/slof/allocator.c new file mode 100644 index 0000000..279b50b --- /dev/null +++ b/src/roms/SLOF/slof/allocator.c @@ -0,0 +1,219 @@ +/****************************************************************************** + * Copyright (c) 2013 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +/* + * All functions concerning interface to slof + */ +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <stdbool.h> +#include <helpers.h> + +#undef DEBUG +//#define DEBUG +#ifdef DEBUG +#define dprintf(_x ...) do { printf ("%s: ", __func__); printf(_x); } while (0); +#else +#define dprintf(_x ...) +#endif + +#define DEFAULT_BLOCK_SIZE 4096 + +#define BM_WORD_SIZE (sizeof(unsigned long)) +#define BM_WORD_BITS (BM_WORD_SIZE * 8) + +struct bitmap { + unsigned long start; + unsigned long size; + unsigned long bm_size; + unsigned long block_size; + unsigned long free_blocks; + unsigned long bmw[]; +}; + +#define BIT(x) (1UL << x) +#define BM_WORD(bmw, n) (bmw[n/BM_WORD_BITS]) +#define BM_WORD_MODULO(n) (n % BM_WORD_BITS) +#define BM_NUM_BITS(reqsize, bsize) ((reqsize / bsize) + (reqsize % bsize? 1 : 0)) + +void bm_clear_bit(unsigned long *bmw, int n) +{ + BM_WORD(bmw, n) &= ~BIT(BM_WORD_MODULO(n)); +} + +void bm_set_bit(unsigned long *bmw, int n) +{ + BM_WORD(bmw, n) |= BIT(BM_WORD_MODULO(n)); +} + +bool bm_test_bit(unsigned long *bmw, int n) +{ +#ifdef DEBUG + //printf("BMW %x, bitpos %d, value %d\n", &BM_WORD(bmw, n), n, !!(BM_WORD(bmw, n) & BIT(BM_WORD_MODULO(n)))); +#endif + return !!(BM_WORD(bmw, n) & BIT(BM_WORD_MODULO(n))); +} + +/* Improvement: can use FFS routines to get faster results */ +int bm_find_bits(struct bitmap *bm, unsigned int n_bits) +{ + unsigned int i, j, total_bits; + int found = -1; + dprintf("Finding %d bits set\n", n_bits); + total_bits = BM_NUM_BITS(bm->size, bm->block_size); + for(i = 0; i < total_bits; i++) { + if (!bm_test_bit(bm->bmw, i)) + continue; + /* we have hit the boundary now, give up */ + if (i + n_bits > total_bits) + break; + /* Lets find if we have consecutive bits set */ + for(j = i; j < (i + n_bits); j++) { + if (!bm_test_bit(bm->bmw, (j))) + break; + } + /* Got it */ + if (j == (i + n_bits)) { + found = i; + break; + } + } + return found; +} + +void SLOF_bm_print(unsigned long handle) +{ + struct bitmap *bm; + unsigned int i; + + if (!handle) + return; + + bm = (struct bitmap *) handle; + printf("BITMAP: start %lx, size %ld, blocksize %ld\n\n", + bm->start, bm->size, bm->block_size); + printf("0 16 32 48 63\n"); + for(i = 0; i < BM_NUM_BITS(bm->size, bm->block_size); i++) { + if (i > 0 && (i % 64 == 0)) + printf("\n"); + else if (i > 0 && (i % 8 == 0)) + printf(" "); + printf("%d", bm_test_bit(bm->bmw, i)); + } + printf("\n\n"); +} + +unsigned long SLOF_bm_allocator_init(unsigned long start, unsigned long size, + unsigned long blocksize) +{ + struct bitmap *bm; + unsigned long alloc_size, bm_size, n_bits; + + dprintf("enter start %x, size %d, block-size %d\n", start, size, blocksize); + + if (!size) + return 0; + if (!blocksize) + blocksize = DEFAULT_BLOCK_SIZE; + + n_bits = BM_NUM_BITS(size, blocksize); + bm_size = (n_bits / BM_WORD_BITS) + ((n_bits % BM_WORD_BITS)? 1 : 0); + alloc_size = sizeof(struct bitmap) + bm_size * BM_WORD_SIZE; + dprintf("Size %ld, blocksize %ld, bm_size %ld, alloc_size %ld\n", + size, blocksize, bm_size, alloc_size); + bm = (struct bitmap *) SLOF_alloc_mem(alloc_size); + if (!bm) + return 0; + bm->start = start; + bm->size = size; + bm->bm_size = bm_size; + bm->block_size = blocksize; + bm->free_blocks = n_bits; + memset(bm->bmw, 0xFF, bm_size*BM_WORD_SIZE); + return (unsigned long)bm; +} + +unsigned long SLOF_bm_alloc(unsigned long handle, unsigned long size) +{ + struct bitmap *bm; + unsigned long n_bits; + unsigned long addr; + unsigned int i; + int bitpos; + + if (!handle) + return -1; + + bm = (struct bitmap *) handle; + + n_bits = BM_NUM_BITS(size, bm->block_size); + if (n_bits > bm->free_blocks) + return -1; + + bitpos = bm_find_bits(bm, n_bits); + if (bitpos == -1) + return -1; + + dprintf("BMW %d, bitpos %d\n", i, bitpos); + dprintf("size %d, block_size %d, n_bits %d\n", size, bm->block_size, n_bits); + for(i = bitpos; i < (bitpos + n_bits); i++) { +#ifdef DEBUG + if (!bm_test_bit(bm->bmw, i)) + dprintf("Warning: Bit already in use: %d\n", i); +#endif + bm_clear_bit(bm->bmw, i); + } + bm->free_blocks -= n_bits; + addr = bm->start + bitpos * bm->block_size; + dprintf("BMW %d, bitpos %d addr %lx free_blocks %d\n", i, bitpos, addr, bm->free_blocks); + return addr; +} + +void SLOF_bm_free(unsigned long handle, unsigned long ptr, unsigned long size) +{ + struct bitmap *bm; + unsigned long bitpos, n_bits; + unsigned long addr; + unsigned int i; + + if (!handle) + return; + + bm = (struct bitmap *) handle; + addr = (unsigned long ) ptr; + n_bits = BM_NUM_BITS(size, bm->block_size); + if (addr < bm->start || (bm->start + bm->size) < (addr + size)) { + printf("Error: Bitmap start %lx, size %ld, requested address %lx, size %ld\n", + bm->start, bm->size, addr, size); + return; + } + bitpos = (addr - bm->start) / bm->block_size; + bm->free_blocks += n_bits; + +#ifdef DEBUG + dprintf("addr %lx, bitpos %d\n", addr, bitpos); + dprintf("size %d, block_size %d, n_bits %d, free_blocks %d\n", size, bm->block_size, n_bits, bm->free_blocks); + if (addr % bm->block_size) { + dprintf("Warning: Address not aligned addr %lx\n", addr); + } +#endif + + for(i = bitpos; i < (bitpos + n_bits); i++) { +#ifdef DEBUG + if (bm_test_bit(bm->bmw, i)) + dprintf("Warning: Bit already set: %d\n", i); +#endif + bm_set_bit(bm->bmw, i); + } + + return; +} diff --git a/src/roms/SLOF/slof/default-font.c b/src/roms/SLOF/slof/default-font.c new file mode 100644 index 0000000..328f1b4 --- /dev/null +++ b/src/roms/SLOF/slof/default-font.c @@ -0,0 +1,1653 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +/* Bitmap font 8x16. + FIXME: Only characters from 0x20 - 0x7f + + +*/ + +const char bmfont_8x16[] = +{ + /* 0x20 " " */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x21 "!" */ + 0x00, + 0x00, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x00, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x22 """ */ + 0x00, + 0x00, + 0x28, + 0x28, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x23 "#" */ + 0x00, + 0x00, + 0x24, + 0x24, + 0x7e, + 0x24, + 0x24, + 0x7e, + 0x24, + 0x24, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x24 "$" */ + 0x00, + 0x08, + 0x1c, + 0x2a, + 0x28, + 0x28, + 0x1c, + 0x0a, + 0x0a, + 0x2a, + 0x1c, + 0x08, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x25 "%" */ + 0x00, + 0x00, + 0x30, + 0x48, + 0x30, + 0x02, + 0x0c, + 0x30, + 0x40, + 0x0c, + 0x12, + 0x0c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x26 "&" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x44, + 0x40, + 0x22, + 0x54, + 0x48, + 0x54, + 0x22, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x27 "'" */ + 0x00, + 0x00, + 0x10, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x28 "(" */ + 0x00, + 0x00, + 0x08, + 0x10, + 0x10, + 0x20, + 0x20, + 0x20, + 0x20, + 0x10, + 0x10, + 0x08, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x29 ")" */ + 0x00, + 0x00, + 0x10, + 0x08, + 0x08, + 0x04, + 0x04, + 0x04, + 0x04, + 0x08, + 0x08, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x2a "*" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x10, + 0x10, + 0x7c, + 0x10, + 0x28, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x2b "+" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x10, + 0x10, + 0x7c, + 0x10, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x2c "," */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x08, + 0x08, + 0x18, + 0x10, + 0x00, + 0x00, + 0x00, + /* 0x2d "-" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x7c, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x2e "." */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x30, + 0x30, + 0x00, + 0x00, + 0x00, + /* 0x2f "/" */ + 0x00, + 0x00, + 0x02, + 0x04, + 0x04, + 0x08, + 0x08, + 0x10, + 0x10, + 0x20, + 0x20, + 0x40, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x30 "0" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x44, + 0x44, + 0x44, + 0x44, + 0x44, + 0x44, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x31 "1" */ + 0x00, + 0x00, + 0x08, + 0x18, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x1c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x32 "2" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x44, + 0x04, + 0x04, + 0x08, + 0x10, + 0x20, + 0x40, + 0x78, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x33 "3" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x04, + 0x04, + 0x04, + 0x18, + 0x04, + 0x04, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x34 "4" */ + 0x00, + 0x00, + 0x40, + 0x40, + 0x40, + 0x48, + 0x48, + 0x7e, + 0x08, + 0x08, + 0x08, + 0x08, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x35 "5" */ + 0x00, + 0x00, + 0x7e, + 0x40, + 0x40, + 0x40, + 0x78, + 0x04, + 0x02, + 0x02, + 0x04, + 0x78, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x36 "6" */ + 0x00, + 0x00, + 0x1c, + 0x20, + 0x40, + 0x40, + 0x40, + 0x78, + 0x44, + 0x44, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x37 "7" */ + 0x00, + 0x00, + 0x7e, + 0x42, + 0x04, + 0x08, + 0x08, + 0x10, + 0x10, + 0x20, + 0x20, + 0x20, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x38 "8" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x44, + 0x44, + 0x38, + 0x44, + 0x44, + 0x44, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x39 "9" */ + 0x00, + 0x00, + 0x38, + 0x44, + 0x44, + 0x44, + 0x3c, + 0x04, + 0x04, + 0x04, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x3a ":" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x30, + 0x30, + 0x00, + 0x00, + 0x30, + 0x30, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x3b ";" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x30, + 0x30, + 0x00, + 0x00, + 0x30, + 0x30, + 0x20, + 0x40, + 0x00, + 0x00, + /* 0x3c "<" */ + 0x00, + 0x00, + 0x04, + 0x08, + 0x10, + 0x20, + 0x40, + 0x40, + 0x20, + 0x10, + 0x08, + 0x04, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x3d "=" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x7e, + 0x00, + 0x7e, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x3e ">" */ + 0x00, + 0x00, + 0x20, + 0x10, + 0x08, + 0x04, + 0x02, + 0x02, + 0x04, + 0x08, + 0x10, + 0x20, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x3f "?" */ + 0x00, + 0x00, + 0x1c, + 0x22, + 0x02, + 0x02, + 0x04, + 0x18, + 0x10, + 0x10, + 0x00, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x40 "@" */ + 0x00, + 0x00, + 0x18, + 0x24, + 0x42, + 0x4e, + 0x52, + 0x4e, + 0x40, + 0x40, + 0x24, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x41 "A" */ + 0x00, + 0x00, + 0x18, + 0x18, + 0x24, + 0x24, + 0x24, + 0x7e, + 0x42, + 0x42, + 0x42, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x42 "B" */ + 0x00, + 0x00, + 0x7c, + 0x42, + 0x42, + 0x42, + 0x7c, + 0x7c, + 0x42, + 0x42, + 0x42, + 0x7c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x44 "C" */ + 0x00, + 0x00, + 0x3c, + 0x22, + 0x60, + 0x40, + 0x40, + 0x40, + 0x40, + 0x60, + 0x22, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x45 "D" */ + 0x00, + 0x00, + 0x78, + 0x44, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x44, + 0x78, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x46 "E" */ + 0x00, + 0x00, + 0x7e, + 0x40, + 0x40, + 0x40, + 0x7e, + 0x7e, + 0x40, + 0x40, + 0x40, + 0x7e, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x47 "F" */ + 0x00, + 0x00, + 0x7e, + 0x40, + 0x40, + 0x40, + 0x7e, + 0x7e, + 0x40, + 0x40, + 0x40, + 0x40, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x48 "G" */ + 0x00, + 0x00, + 0x3c, + 0x42, + 0x40, + 0x40, + 0x40, + 0x40, + 0x4e, + 0x42, + 0x42, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x49 "H" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x42, + 0x42, + 0x7e, + 0x7e, + 0x42, + 0x42, + 0x42, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x49 "I" */ + 0x00, + 0x00, + 0x3c, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4a "J" */ + 0x00, + 0x00, + 0x04, + 0x04, + 0x04, + 0x04, + 0x04, + 0x04, + 0x04, + 0x04, + 0x24, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4b "K" */ + 0x00, + 0x00, + 0x42, + 0x44, + 0x48, + 0x50, + 0x60, + 0x60, + 0x50, + 0x48, + 0x44, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4c "L" */ + 0x00, + 0x00, + 0x40, + 0x40, + 0x40, + 0x40, + 0x40, + 0x40, + 0x40, + 0x40, + 0x40, + 0x7e, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4d "M" */ + 0x00, + 0x00, + 0x42, + 0x66, + 0x7e, + 0x5a, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4e "N" */ + 0x00, + 0x00, + 0x42, + 0x62, + 0x62, + 0x52, + 0x52, + 0x4a, + 0x4a, + 0x46, + 0x46, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x4f "O" */ + 0x00, + 0x00, + 0x18, + 0x24, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x24, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x50 "P" */ + 0x00, + 0x00, + 0x70, + 0x48, + 0x44, + 0x44, + 0x48, + 0x70, + 0x40, + 0x40, + 0x40, + 0x40, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x51 "Q" */ + 0x00, + 0x00, + 0x18, + 0x24, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x4a, + 0x24, + 0x1a, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x52 "R" */ + 0x00, + 0x00, + 0x70, + 0x48, + 0x44, + 0x44, + 0x48, + 0x70, + 0x50, + 0x48, + 0x44, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x53 "S" */ + 0x00, + 0x00, + 0x1e, + 0x20, + 0x40, + 0x40, + 0x20, + 0x18, + 0x04, + 0x02, + 0x02, + 0x7e, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x54 "T" */ + 0x00, + 0x00, + 0x7e, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x55 "U" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x56 "V" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x24, + 0x24, + 0x24, + 0x24, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x57 "W" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x42, + 0x5a, + 0x66, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x58 "X" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x24, + 0x24, + 0x18, + 0x18, + 0x24, + 0x24, + 0x42, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x59 "Y" */ + 0x00, + 0x00, + 0x42, + 0x42, + 0x24, + 0x24, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5a "Z" */ + 0x00, + 0x00, + 0x7e, + 0x42, + 0x04, + 0x04, + 0x08, + 0x10, + 0x20, + 0x20, + 0x42, + 0x7e, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5b "[" */ + 0x00, + 0x00, + 0x30, + 0x20, + 0x20, + 0x20, + 0x20, + 0x20, + 0x20, + 0x20, + 0x20, + 0x30, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5c "\" */ + 0x00, + 0x00, + 0x40, + 0x20, + 0x20, + 0x10, + 0x10, + 0x08, + 0x08, + 0x04, + 0x04, + 0x02, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5d "]" */ + 0x00, + 0x00, + 0x18, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5e "^" */ + 0x00, + 0x00, + 0x18, + 0x3c, + 0x66, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x5f "_" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x7e, + 0x00, + /* 0x60 "`" */ + 0x00, + 0x00, + 0x00, + 0x20, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x61 "a" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x38, + 0x44, + 0x04, + 0x3c, + 0x44, + 0x3a, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x62 "b" */ + 0x00, + 0x00, + 0x40, + 0x40, + 0x40, + 0x40, + 0x58, + 0x64, + 0x44, + 0x44, + 0x64, + 0x58, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x63 "c" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x38, + 0x44, + 0x40, + 0x40, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x64 "d" */ + 0x00, + 0x00, + 0x04, + 0x04, + 0x04, + 0x04, + 0x3c, + 0x4c, + 0x44, + 0x44, + 0x4c, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x65 "e" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x38, + 0x44, + 0x78, + 0x40, + 0x44, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x66 "f" */ + 0x00, + 0x00, + 0x0c, + 0x12, + 0x10, + 0x10, + 0x38, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x67 "g" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x34, + 0x4c, + 0x44, + 0x4c, + 0x34, + 0x04, + 0x44, + 0x38, + 0x00, + 0x00, + /* 0x68 "h" */ + 0x00, + 0x00, + 0x40, + 0x40, + 0x40, + 0x58, + 0x64, + 0x44, + 0x44, + 0x44, + 0x44, + 0x44, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x69 "i" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x08, + 0x00, + 0x18, + 0x08, + 0x08, + 0x08, + 0x08, + 0x1c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x6a "j" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x08, + 0x00, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x48, + 0x30, + 0x00, + /* 0x6b "k" */ + 0x00, + 0x00, + 0x40, + 0x40, + 0x40, + 0x44, + 0x48, + 0x50, + 0x70, + 0x48, + 0x44, + 0x42, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x6c "l" */ + 0x00, + 0x00, + 0x30, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x38, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x6d "m" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x54, + 0x2a, + 0x2a, + 0x2a, + 0x2a, + 0x6a, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x6e "n" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x58, + 0x24, + 0x24, + 0x24, + 0x24, + 0x76, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x6f "o" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x1c, + 0x22, + 0x22, + 0x22, + 0x22, + 0x1c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x70 "p" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x58, + 0x64, + 0x44, + 0x64, + 0x58, + 0x40, + 0x40, + 0x40, + 0x00, + 0x00, + /* 0x71 "q" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x34, + 0x4c, + 0x44, + 0x4c, + 0x34, + 0x04, + 0x04, + 0x04, + 0x00, + 0x00, + /* 0x72 "r" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x78, + 0x44, + 0x40, + 0x40, + 0x40, + 0x40, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x73 "s" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x18, + 0x24, + 0x10, + 0x08, + 0x24, + 0x18, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x74 "t" */ + 0x00, + 0x00, + 0x10, + 0x10, + 0x10, + 0x38, + 0x10, + 0x10, + 0x10, + 0x10, + 0x14, + 0x08, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x75 "u" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x24, + 0x24, + 0x24, + 0x24, + 0x24, + 0x1a, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x76 "v" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x44, + 0x44, + 0x44, + 0x28, + 0x28, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x77 "w" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x2a, + 0x2a, + 0x2a, + 0x2a, + 0x2a, + 0x14, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x78 "x" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x44, + 0x44, + 0x28, + 0x10, + 0x28, + 0x44, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x79 "y" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x22, + 0x22, + 0x14, + 0x14, + 0x08, + 0x08, + 0x10, + 0x20, + 0x00, + 0x00, + /* 0x7a "z" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x3c, + 0x04, + 0x08, + 0x10, + 0x20, + 0x3c, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x7b "{" */ + 0x00, + 0x04, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x08, + 0x10, + 0x08, + 0x08, + 0x08, + 0x08, + 0x04, + 0x00, + 0x00, + /* 0x7c "|" */ + 0x00, + 0x00, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x00, + 0x00, + /* 0x7d "}" */ + 0x00, + 0x20, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x08, + 0x10, + 0x10, + 0x10, + 0x10, + 0x10, + 0x20, + 0x00, + 0x00, + /* 0x7e "~" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x24, + 0x54, + 0x48, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + /* 0x7f "v" */ + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x00, + 0x44, + 0x44, + 0x44, + 0x28, + 0x28, + 0x10, + 0x00, + 0x00, + 0x00, + 0x00 +}; diff --git a/src/roms/SLOF/slof/engine.in b/src/roms/SLOF/slof/engine.in new file mode 100644 index 0000000..0344a38 --- /dev/null +++ b/src/roms/SLOF/slof/engine.in @@ -0,0 +1,542 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +// ============================================================================ +// ============================================================================ + + +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + +// This is the core engine of Paflof. It is almost ANS Forth compatible. +// There are two possibilities why an aspect would not be: +// a) Open Firmware requires different semantics; +// b) bugs. +// Most of the "extended" semantics defined in the OF specification are +// not implemented; just the bare essentials. For example, you can't +// use structural words (IF, THEN, BEGIN, etc.) or return-stack +// manipulation words (R> etc.) in the interpreter. + +// The data stack pointer. +raw(HERE DOVAL _A(the_mem)) + +// Some common constant numbers; smaller and faster if they are defined +// as constants, than when inlined as a literal. +con(-1 -1) +con(0 0) +con(1 1) +con(2 2) +con(3 3) +con(4 4) +con(8 8) +con(H#10 0x10) +con(H#20 0x20) +con(H#FF 0xff) +con(H#FFFF 0xffff) +con(H#FFFFFFFF 0xffffffff) +con(D#10 0x0a) + + +// Manipulating different kinds of addresses. +con(/C 1) +con(/W 2) +con(/L 4) +con(/X 8) +con(/N CELLSIZE) +con(CELL CELLSIZE) +col(/C* /C *) +col(/W* /W *) +col(/L* /L *) +col(/X* /X *) +col(/N* /N *) +col(CA+ /C* +) +col(WA+ /W* +) +col(LA+ /L* +) +col(XA+ /X* +) +col(NA+ /N* +) +col(CA1+ /C +) +col(WA1+ /W +) +col(LA1+ /L +) +col(XA1+ /X +) +col(NA1+ /N +) +col(CHAR+ CA1+) +col(CELL+ NA1+) +col(CHAR- /C -) +col(CELL- /N -) +col(CHARS /C*) +col(CELLS /N*) +col(CHARS+ CA+) +col(CELLS+ NA+) + + +// Run-time words for TO and for string literals. +col(DOTO R> CELL+ DUP >R @ CELL+ !) +col(SLITERAL R> CELL+ DUP DUP C@ + LIT(-CELLSIZE) AND >R) + + +// Stack manipulation. +col(?DUP DUP 0BRANCH(1) DUP) +col(TUCK SWAP OVER) +col(2DUP OVER OVER) +col(3DUP 2 PICK 2 PICK 2 PICK) +col(2OVER 3 PICK 3 PICK) +col(2DROP DROP DROP) +col(3DROP DROP DROP DROP) +col(NIP SWAP DROP) +col(CLEAR 0 DEPTH!) +col(ROT >R SWAP R> SWAP) +col(-ROT SWAP >R SWAP R>) +col(2SWAP >R -ROT R> -ROT) +col(2ROT >R >R 2SWAP R> R> 2SWAP) +col(ROLL DUP ?DUP 0BRANCH(6) ROT >R 1 - BRANCH(-9) ?DUP 0BRANCH(6) R> -ROT 1 - BRANCH(-9)) +col(-ROLL DUP ?DUP 0BRANCH(9) >R ROT R> SWAP >R 1 - BRANCH(-12) ?DUP 0BRANCH(6) R> SWAP 1 - BRANCH(-9)) +col(2>R R> ROT >R SWAP >R >R) +col(2R> R> R> R> ROT >R SWAP) +col(2R@ R> R> R@ OVER >R ROT >R SWAP) +cod(?PICK) + +// Arithmetic. +col(2* 1 LSHIFT) +col(U2/ 1 RSHIFT) +col(2/ 1 ASHIFT) +col(<< LSHIFT) +col(>> RSHIFT) +col(>>A ASHIFT) +col(INVERT -1 XOR) +col(NOT INVERT) + + +// Booleans. +con(TRUE -1) +con(FALSE 0) + + +// Comparisons. +col(> SWAP <) +col(U> SWAP U<) +col(<= > 0=) +col(<> = 0=) +col(>= < 0=) +col(0<= 0 <=) +col(0<> 0 <>) +col(0> 0 >) +col(0>= 0 >=) +col(U<= U> 0=) +col(U>= U< 0=) +col(WITHIN ROT DUP ROT >= 0BRANCH(3) 2DROP FALSE EXIT > 0BRANCH(2) FALSE EXIT TRUE) +col(BETWEEN 1 + WITHIN) + +// Double-cell single-bit shifts. +col(D2* 2* OVER 0< - >R 2* R>) +col(UD2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> U2/) +col(D2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> 2/) + + +// More arithmetic. +col(NEGATE 0 SWAP -) +col(ABS DUP 0< 0BRANCH(1) NEGATE) +col(MAX 2DUP < 0BRANCH(1) SWAP DROP) +col(MIN 2DUP > 0BRANCH(1) SWAP DROP) +col(U* *) +col(1+ 1 +) +col(1- 1 -) +col(2+ 2 +) +col(2- 2 -) +col(EVEN 1+ -1 AND) +col(BOUNDS OVER + SWAP) + + +// Double-cell and mixed-size arithmetic. +col(S>D DUP 0<) +col(DNEGATE INVERT >R NEGATE DUP 0= R> SWAP -) +col(DABS DUP 0< 0BRANCH(1) DNEGATE) +col(M+ SWAP >R DUP >R + DUP R> U< R> SWAP -) +col(D+ >R M+ R> +) +col(D- DNEGATE D+) +col(*' >R DUP 0< >R D2* R> 0BRANCH(2) R@ M+ R>) +col(UM* 0 -ROT LIT(8*CELLSIZE) 0 DODO *' DOLOOP(-3) DROP) +col(M* 2DUP XOR >R >R ABS R> ABS UM* R> 0< 0BRANCH(1) DNEGATE) +col(/' >R DUP 0< >R D2* R> OVER R@ U>= OR 0BRANCH(6) >R 1 OR R> R@ - R>) +col(UM/MOD LIT(8*CELLSIZE) 0 DODO /' DOLOOP(-3) DROP SWAP) +col(SM/REM OVER >R >R DABS R@ ABS UM/MOD R> 0< 0BRANCH(1) NEGATE R> 0< 0BRANCH(4) NEGATE SWAP NEGATE SWAP) +col(FM/MOD DUP >R 2DUP XOR 0< >R SM/REM OVER 0<> R> AND 0BRANCH(6) 1- SWAP R> + SWAP EXIT R> DROP) + + +// Division. +col(U/MOD 0 SWAP UM/MOD) +col(/MOD >R S>D R> FM/MOD) +col(/ /MOD NIP) +col(MOD /MOD DROP) +col(*/MOD >R M* R> FM/MOD) +col(*/ */MOD NIP) + + +// Splitting, joining, flipping the components of a number. +col(WBSPLIT DUP H#FF AND SWAP 8 RSHIFT) +col(LWSPLIT DUP H#FFFF AND SWAP H#10 RSHIFT) +col(XLSPLIT DUP H#FFFFFFFF AND SWAP H#20 RSHIFT) +col(LBSPLIT LWSPLIT >R WBSPLIT R> WBSPLIT) +col(XWSPLIT XLSPLIT >R LWSPLIT R> LWSPLIT) +col(XBSPLIT XLSPLIT >R LBSPLIT R> LBSPLIT) +col(BWJOIN 8 LSHIFT OR) +col(WLJOIN H#10 LSHIFT OR) +col(BLJOIN BWJOIN >R BWJOIN R> WLJOIN) +col(WBFLIP WBSPLIT SWAP BWJOIN) +col(LWFLIP LWSPLIT SWAP WLJOIN) +col(LXJOIN H#20 LSHIFT OR) +col(XLFLIP XLSPLIT SWAP LXJOIN) +col(LBFLIP LBSPLIT SWAP 2SWAP SWAP BLJOIN) +col(WXJOIN WLJOIN >R WLJOIN R> LXJOIN) +col(XWFLIP XWSPLIT SWAP 2SWAP SWAP WXJOIN) +col(BXJOIN BLJOIN >R BLJOIN R> LXJOIN) +col(XBFLIP XLSPLIT LBFLIP SWAP LBFLIP LXJOIN) + +// Aligning to cell size. +col(ALIGNED /N 1- + /N NEGATE AND) + + +// Counted loop stuff. +col(I R> R@ SWAP >R) +col(J R> R> R> R@ SWAP >R SWAP >R SWAP >R) +col(UNLOOP R> R> R> 2DROP >R) + + +// Memory accesses. +col(+! TUCK @ + SWAP !) +cod(COMP) +col(OFF FALSE SWAP !) +col(ON TRUE SWAP !) +col(<W@ W@ DUP LIT(0x8000) >= 0BRANCH(3) LIT(0x10000) -) +col(2@ DUP CELL+ @ SWAP @) +col(2! DUP >R ! R> CELL+ !) +col(WBFLIPS BOUNDS DO?DO(8) I W@ WBFLIP I W! /W DO+LOOP(-8)) +col(LWFLIPS BOUNDS DO?DO(8) I L@ LWFLIP I L! /L DO+LOOP(-8)) +col(LBFLIPS BOUNDS DO?DO(8) I L@ LBFLIP I L! /L DO+LOOP(-8)) +col(XBFLIPS BOUNDS DO?DO(8) I X@ XBFLIP I X! /X DO+LOOP(-8)) +col(XWFLIPS BOUNDS DO?DO(8) I X@ XWFLIP I X! /X DO+LOOP(-8)) +col(XLFLIPS BOUNDS DO?DO(8) I X@ XLFLIP I X! /X DO+LOOP(-8)) +cod(FILL) +col(BLANK LIT(0x20) FILL) +col(ERASE LIT(0x00) FILL) + + +// Exception handling. +var(CATCHER 0) +var(ABORT"-STR 0) +col(CATCH DEPTH >R CATCHER @ >R RDEPTH CATCHER ! EXECUTE R> CATCHER ! R> DROP 0) +col(THROW ?DUP 0BRANCH(12) CATCHER @ RDEPTH! R> CATCHER ! R> SWAP >R DEPTH! DROP R>) +col(ABORT -1 THROW) + + +// Text input. +var(#TIB TIBSIZE) +val(IB 0) +var(#IB 0) +val(SOURCE-ID 0) +col(SOURCE IB #IB @) +var(>IN 0) +col(TERMINAL TIB DOTO IB #TIB @ #IB ! 0 DOTO SOURCE-ID) + + +// ASCII codes. +con(BL 0x20) +con(BELL 7) +con(BS 8) +con(CARRET 0x0d) +con(LINEFEED 0x0a) + + +// Text output. +dfr(EMIT) +dfr(CR) +col(TYPE BOUNDS DO?DO(5) I C@ EMIT DOLOOP(-5)) +col(LL-CR CARRET EMIT LINEFEED EMIT) +col(SPACE BL EMIT) +col(SPACES 0 DO?DO(3) SPACE DOLOOP(-3)) + + +// Text manipulation. +col(COUNT DUP CHAR+ SWAP C@) +col(PACK DUP >R 1+ SWAP DUP R@ C! MOVE R>) +col(UPC DUP LIT('a') LIT('z') BETWEEN 0BRANCH(3) LIT(0x20) - ) +col(LCC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(0x20) + ) + + +// Text input. +dfr(KEY) +dfr(KEY?) +dfr(ACCEPT) +var(SPAN 0) +col(EXPECT ACCEPT SPAN !) +col(REFILL SOURCE-ID 0= 0BRANCH(7) SOURCE EXPECT 0 >IN ! TRUE EXIT SOURCE-ID -1 = 0BRANCH(2) FALSE EXIT LIT(0x6502) THROW) + + +// Number base. +var(BASE 16) +col(DECIMAL D#10 BASE !) +col(HEX H#10 BASE !) +col(OCTAL 8 BASE !) + + +// Pictured numeric output. +col(PAD HERE LIT(256) +) +col(TODIGIT DUP LIT(9) > 0BRANCH(3) LIT(0x27) + LIT(0x30) +) +col(MU/MOD DUP >R U/MOD R> SWAP >R UM/MOD R>) +col(<# PAD DUP !) +col(HOLD PAD DUP @ 1- TUCK SWAP ! C!) +col(SIGN 0< 0BRANCH(3) LIT('-') HOLD) +col(# BASE @ MU/MOD ROT TODIGIT HOLD) +col(#S # 2DUP OR 0BRANCH(2) BRANCH(-7)) +col(#> 2DROP PAD DUP @ TUCK -) +col((.) <# DUP >R ABS 0 #S R> SIGN #>) +col(U# BASE @ U/MOD SWAP TODIGIT HOLD) +col(U#S U# DUP 0BRANCH(2) BRANCH(-6)) +col(U#> DROP PAD DUP @ TUCK -) +col((U.) <# U#S U#>) +col(. (.) TYPE SPACE) +col(S. .) +col(U. (U.) TYPE SPACE) +col(.R SWAP (.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE) +col(U.R SWAP (U.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE) +col(.D BASE @ SWAP DECIMAL . BASE !) +col(.H BASE @ SWAP HEX . BASE !) +col(.S DEPTH DUP 0< 0BRANCH(2) DROP EXIT 0 DO?DO(8) DEPTH I - 1- PICK . DOLOOP(-8)) +col(? @ .) + + +// Numeric input. +col(DIGIT OVER UPC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(7) - LIT(0x30) - DUP ROT 0 SWAP WITHIN 0BRANCH(4) NIP TRUE BRANCH(2) DROP FALSE) +col(>NUMBER DUP 0= 0BRANCH(1) EXIT OVER C@ BASE @ DIGIT 0BRANCH(23) SWAP >R SWAP >R >R BASE @ U* SWAP BASE @ UM* ROT + R> 0 D+ R> CHAR+ R> 1- BRANCH(-35) DROP) +col($NUMBER DUP 0= 0BRANCH(4) DROP DROP TRUE EXIT >R DUP >R C@ LIT('-') = DUP 0BRANCH(15) R> CHAR+ R> 1- DUP 0= 0BRANCH(5) DROP DROP DROP TRUE EXIT >R >R 0 0 R> R> >NUMBER NIP 0= 0BRANCH(7) DROP SWAP 0BRANCH(1) NEGATE FALSE EXIT DROP DROP DROP TRUE) + + +// Data space allocation. +col(ALLOT HERE + DOTO HERE) +col(, HERE ! /N ALLOT) +col(C, HERE C! /C ALLOT) +col(W, HERE W! /W ALLOT) +col(L, HERE L! /L ALLOT) +col(X, HERE X! /X ALLOT) +col(ALIGN HERE /N 1- AND 0BRANCH(4) 0 C, BRANCH(-10)) +col(PLACE 2DUP C! CHAR+ SWAP CHARS BOUNDS DO?DO(9) DUP C@ I C! CHAR+ 1 CHARS DO+LOOP(-9) DROP) +col(STRING, HERE OVER 1+ CHARS ALLOT PLACE) + + +// Every language needs a no-op. +col(NOOP) + + +// Now it gets ugly: search-order and word-lisst infrastructure. + +raw(FORTH-WORDLIST DODOES _A(xt_NOOP+2+(8/sizeof(long))) _A(0) _A(0)) + // Engine initialisation will set this last cell to the xt of LASTWORD. + +// compilation dictionary +raw(CURRENT DOVAL _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long)))) + // +7 for 32-bit, +5 for 64-bit + +col(LAST CURRENT CELL+) + +// for context dictionaries +raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0)) + // +7 for 32-bit, +5 for 64-bit +// for context dictionaries +//raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(sizeof(" FORTH-WORDLIST")/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0)) +// +7 for 32-bit, +5 for 64-bit +raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+2+(16/sizeof(long)))) +//raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+6)) +// +6 for 32-bit, +4 for 64-bit + +// Dictionary structure. +col(LINK>NAME CELL+) +col(NAME> CHAR+ DUP C@ 1+ CHARS+ ALIGNED) +col(LINK> LINK>NAME NAME>) +col(NAME>STRING CHAR+ COUNT) + +// Creating word headers. +var(LATEST 0) +dfr((REVEAL)) +col(HEADER ALIGN HERE LAST @ , LATEST ! 0 C, STRING, ALIGN) +col(REVEAL LATEST @ LINK>NAME NAME>STRING (REVEAL) LATEST @ LAST !) + + +// Finding words. +cod(STRING=CI) +// (find) ( str len head -- 0 | link ) +dfr((FIND)) +col(((FIND)) DUP 0BRANCH(15) >R 2DUP R@ LINK>NAME NAME>STRING STRING=CI 0BRANCH(3) 2DROP R> EXIT R> @ BRANCH(-18) 3DROP FALSE) +col((FIND-ORDER) CONTEXT DUP >R SEARCH-ORDER U>= 0BRANCH(18) 2DUP R@ @ CELL+ @ (FIND) ?DUP 0BRANCH(5) NIP NIP R> DROP EXIT R> CELL- BRANCH(-24) R> 3DROP 0) +col(($FIND) (FIND-ORDER) DUP 0BRANCH(6) LINK>NAME DUP NAME> SWAP C@ TRUE) +col($FIND 2DUP ($FIND) 0BRANCH(6) DROP NIP NIP TRUE BRANCH(1) FALSE) + +// Flags on words. +con('IMMEDIATE 1) +col(IMMEDIATE? 'IMMEDIATE AND 0<>) +col(IMMEDIATE LAST @ CELL+ DUP C@ 'IMMEDIATE OR SWAP C!) + +// Parsing. +col(FINDCHAR SWAP 0 DO?DO(24) OVER I + C@ OVER DUP BL = 0BRANCH(3) <= BRANCH(1) = 0BRANCH(6) I UNLOOP NIP NIP TRUE EXIT DOLOOP(-24) DROP DROP FALSE) +col(PARSE >R IB >IN @ + SPAN @ >IN @ - 2DUP R> FINDCHAR 0BRANCH(6) NIP DUP 1 + BRANCH(1) DUP >IN +!) +col(SKIPWS IB SPAN @ DUP >IN @ > 0BRANCH(14) OVER >IN @ + C@ BL <= 0BRANCH(5) 1 >IN +! BRANCH(-20) DROP DROP) +col(PARSE-WORD SKIPWS BL PARSE) +var(WHICHPOCKET 0) +// We reserved 0x1000 for the pockets. So we have 16 pockets a 0x100 +col(POCKET POCKETS WHICHPOCKET @ LIT(POCKETSIZE) * + WHICHPOCKET @ 1 + DUP LIT(NUMPOCKETS) = 0BRANCH(2) DROP 0 WHICHPOCKET !) + +col(WORD POCKET >R PARSE DUP R@ C! BOUNDS R> DUP 2SWAP DO?DO(7) CHAR+ I C@ OVER C! DOLOOP(-7) DROP) + +// Some simple parsing words. +col(CHAR PARSE-WORD DROP C@) +imm(( LIT(')') PARSE 2DROP) +// Removing comments out of the code, the code from the backslash to the next \n is removed. +// We need to start from cursor -1 (the backslash) to handle the case backslash+linefeed correctly 0x5c0a +imm(\ >IN @ 1- >IN ! LINEFEED PARSE 2DROP) + +// The compiler infrastructure. +var(STATE 0) +imm([ STATE OFF) +col(] LIT(0x100) STATE !) +col(?COMP STATE @ 0BRANCH(1) EXIT LIT(-134) THROW) + +col(COMPILE, ,) +col(: PARSE-WORD HEADER DOTICK DOCOL COMPILE, ]) +col(:NONAME ALIGN HERE DOTICK DOCOL COMPILE, ]) +imm(; ?COMP DOTICK SEMICOLON COMPILE, REVEAL [) + +// Compiling strings. +imm(C" ?COMP LIT('"') PARSE DOTICK SLITERAL COMPILE, DUP C, BOUNDS DO?DO(5) I C@ C, DOLOOP(-5) ALIGN) +imm(S" STATE @ 0BRANCH(5) C" DOTICK COUNT COMPILE, EXIT LIT('"') PARSE DUP >R POCKET DUP >R SWAP MOVE R> R>) +imm(Z" S" 2DUP + 0 SWAP C! DROP) +imm(." STATE @ 0BRANCH(5) S" DOTICK TYPE COMPILE, EXIT LIT('"') PARSE TYPE) +imm(.( LIT(')') PARSE TYPE) + +col(COMPILE R> CELL+ DUP @ COMPILE, >R) + +var(THERE 0) +col(+COMP STATE @ 1 STATE +! 0BRANCH(1) EXIT HERE THERE ! COMP-BUFFER DOTO HERE COMPILE DOCOL) +col(-COMP -1 STATE +! STATE @ 0BRANCH(1) EXIT COMPILE EXIT THERE @ DOTO HERE COMP-BUFFER EXECUTE) + +// Structure words. +col(RESOLVE-ORIG HERE OVER CELL+ - SWAP !) +imm(AHEAD +COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE,) +imm(IF +COMP DOTICK DO0BRANCH COMPILE, HERE 0 COMPILE,) +imm(THEN ?COMP RESOLVE-ORIG -COMP) +imm(ELSE ?COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE, SWAP RESOLVE-ORIG) + +imm(CASE +COMP 0) +imm(ENDCASE ?COMP DOTICK DROP COMPILE, ?DUP 0BRANCH(5) 1- SWAP THEN BRANCH(-8) -COMP) +imm(OF ?COMP 1+ >R DOTICK OVER COMPILE, DOTICK = COMPILE, IF DOTICK DROP COMPILE, R>) +imm(ENDOF ?COMP >R ELSE R>) + +col(RESOLVE-DEST HERE CELL+ - COMPILE,) +imm(BEGIN +COMP HERE) +imm(AGAIN ?COMP DOTICK DOBRANCH COMPILE, RESOLVE-DEST -COMP) +imm(UNTIL ?COMP DOTICK DO0BRANCH COMPILE, RESOLVE-DEST -COMP) +imm(WHILE ?COMP IF SWAP) +imm(REPEAT ?COMP AGAIN THEN) + +// Counted loops. +var(LEAVES 0) +col(RESOLVE-LOOP LEAVES @ ?DUP 0BRANCH(10) DUP @ SWAP HERE OVER - SWAP ! BRANCH(-13) HERE - COMPILE, LEAVES !) +imm(DO +COMP LEAVES @ HERE DOTICK DODO COMPILE, 0 LEAVES !) +imm(?DO +COMP LEAVES @ DOTICK DODO?DO COMPILE, HERE HERE LEAVES ! 0 COMPILE,) +imm(LOOP ?COMP DOTICK DODOLOOP COMPILE, RESOLVE-LOOP -COMP) +imm(+LOOP ?COMP DOTICK DODO+LOOP COMPILE, RESOLVE-LOOP -COMP) +imm(LEAVE ?COMP DOTICK DODOLEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,) +imm(?LEAVE ?COMP DOTICK DODO?LEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,) + +// Interpreter nesting. +col(SAVE-SOURCE R> IB >R #IB @ >R SOURCE-ID >R SPAN @ >R >IN @ >R >R) +col(RESTORE-SOURCE R> R> >IN ! R> SPAN ! R> DOTO SOURCE-ID R> #IB ! R> DOTO IB >R) + +// System replies. +str(OK-STR "ok") +str(ABORTED-STR "Aborted") +str(EXCEPTION-STR "Exception #") +str(UNKNOWN-STR "Undefined word") +dfr(HW-EXCEPTION-HANDLER) +val(SHOW-STACK? 0) +col(SHOWSTACK -1 DOTO SHOW-STACK?) +col(NOSHOWSTACK 0 DOTO SHOW-STACK?) +col(PRINT-STACK SHOW-STACK? 0BRANCH(5) >R >R .S R> R> ) +col(PRINT-EXCEPTION DUP LIT(-99) = 0BRANCH(7) DOTICK UNKNOWN-STR COUNT TYPE CR DROP EXIT DUP LIT(0x100) = 0BRANCH(2) DROP EXIT HW-EXCEPTION-HANDLER ) +col(PRINT-STATUS SPACE DUP 0= 0BRANCH(5) PRINT-STACK DOTICK OK-STR BRANCH(7) DUP -1 = 0BRANCH(6) DOTICK ABORTED-STR COUNT TYPE BRANCH(10) DUP LIT(-2) = 0BRANCH(7) ABORT"-STR @ COUNT TYPE DROP BRANCH(1) PRINT-EXCEPTION CR) + +// The compiler and interpreter. +col(COMPILE-WORD 2DUP ($FIND) 0BRANCH(10) IMMEDIATE? 0BRANCH(4) NIP NIP EXECUTE EXIT COMPILE, 2DROP EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW DOTICK DOLIT COMPILE, COMPILE, 2DROP) +col(INTERPRET-WORD 2DUP ($FIND) 0BRANCH(5) DROP NIP NIP EXECUTE EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW >R 2DROP R>) +col(INTERPRET 0 >IN ! PARSE-WORD DUP 0BRANCH(10) STATE @ 0BRANCH(3) COMPILE-WORD BRANCH(1) INTERPRET-WORD BRANCH(-14) 2DROP) + +// Evaluate, the one word to rule them all. It is evil, btw. +col(EVALUATE SAVE-SOURCE -1 DOTO SOURCE-ID DUP #IB ! SPAN ! DOTO IB DOTICK INTERPRET CATCH RESTORE-SOURCE THROW) +col(EVAL EVALUATE) + +// Abort with a message. +col(DOABORT" SWAP 0BRANCH(5) ABORT"-STR ! LIT(-2) THROW DROP) +imm(ABORT" C" DOTICK DOABORT" COMPILE,) + +// Tick. +str(UNDEFINED-STR "undefined word ") +col(SET-UNDEFINED-WORD POCKET >R DOTICK UNDEFINED-STR DUP C@ 1+ R@ SWAP MOVE R@ DUP C@ 1+ + SWAP DUP R@ C@ + R@ C! MOVE R>) +col(' PARSE-WORD $FIND 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT") + +// The outer interpreter. +col(QUIT 0 RDEPTH! [ TERMINAL DEPTH . LIT('>') EMIT SPACE REFILL 0BRANCH(10) SPACE DOTICK INTERPRET CATCH DUP PRINT-STATUS 0BRANCH(-17) BRANCH(-23)) + +// Reading and writing to/from file; including files. +dfr(MAP-FILE) +dfr(UNMAP-FILE) +dfr(WRITE-FILE) +col(INCLUDED MAP-FILE 2DUP >R >R BOUNDS DO?DO(21) R> R@ SWAP >R R@ - R@ SWAP 2DUP LINEFEED FINDCHAR 0BRANCH(1) NIP DUP >R EVALUATE R> 1+ DO+LOOP(-21) R> R> UNMAP-FILE) +col(INCLUDE PARSE-WORD INCLUDED) + +// CREATE ... DOES> ... +col($CREATE HEADER DOTICK DODOES COMPILE, DOTICK NOOP CELL+ COMPILE, REVEAL) +col(CREATE PARSE-WORD $CREATE) +col(DODOES> R> CELL+ LATEST @ LINK> CELL+ !) +imm(DOES> DOTICK DODOES> COMPILE,) + +// Defining words. +col(CONSTANT PARSE-WORD HEADER DOTICK DOCON COMPILE, COMPILE, REVEAL) +col(VALUE PARSE-WORD HEADER DOTICK DOVAL COMPILE, COMPILE, REVEAL) +col(VARIABLE PARSE-WORD HEADER DOTICK DOVAR COMPILE, 0 COMPILE, REVEAL) +col(BUFFER: PARSE-WORD HEADER DOTICK DOBUFFER: COMPILE, ALLOT REVEAL) +col(DEFER PARSE-WORD HEADER DOTICK DODEFER COMPILE, DOTICK ABORT COMPILE, REVEAL) +col(ALIAS PARSE-WORD HEADER DOTICK DOALIAS COMPILE, ' COMPILE, REVEAL) +col(STRUCT 0) +col(END-STRUCT DROP) +col(FIELD PARSE-WORD HEADER DOTICK DOFIELD COMPILE, OVER , + REVEAL) + +// Words with (mostly) non-standard compilation behaviour. +imm(LITERAL DOTICK DOLIT COMPILE, COMPILE,) +imm([COMPILE] ' COMPILE,) +imm(POSTPONE PARSE-WORD 2DUP ($FIND) 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT" IMMEDIATE? 0= 0BRANCH(6) DOTICK DOTICK COMPILE, COMPILE, DOTICK COMPILE, COMPILE, 2DROP) +imm([CHAR] CHAR LITERAL) +imm(['] ' DOTICK DOTICK COMPILE, COMPILE,) + +// FIND. +col(FIND DUP COUNT ($FIND) 0BRANCH(9) ROT DROP TRUE SWAP IMMEDIATE? 0BRANCH(1) NEGATE EXIT FALSE EXIT) + +// Accessing data in CREATE'd words. +imm(TO ' STATE @ 0BRANCH(5) DOTICK DOTO COMPILE, COMPILE, EXIT CELL+ !) +col(BEHAVIOR CELL+ @) +col(>BODY 2 CELLS +) +col(BODY> 2 CELLS -) + +// Making words recursive. +imm(RECURSIVE REVEAL) +imm(RECURSE LATEST @ LINK> COMPILE,) + +// Numeric input. +imm(d# PARSE-WORD BASE @ >R DECIMAL EVALUATE R> BASE !) +imm(h# PARSE-WORD BASE @ >R HEX EVALUATE R> BASE !) +imm(o# PARSE-WORD BASE @ >R OCTAL EVALUATE R> BASE !) diff --git a/src/roms/SLOF/slof/entry.S b/src/roms/SLOF/slof/entry.S new file mode 100644 index 0000000..d3d29f8 --- /dev/null +++ b/src/roms/SLOF/slof/entry.S @@ -0,0 +1,219 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +#include <macros.h> + +#define STACKSIZE 0x2000 + + # + # The generic exception code. + # + # Enter with GPR0 = vector, SPRG0 = saved GPR0 + # + + .section ".entry_text" + +the_handler: + .quad handler + +eregs: + /* the_exception_frame is a C variable which is usually + * defined in $(TARG).c + * the_exception_frame can be accessed from paflof through + * the word eregs + * in the case an excpetion is handled paflof will read + * from eregs the values of all registers and print them + * out in the exception handler */ + .quad the_exception_frame + +handler: + mtsprg 1,1 # SPRG1 = saved GPR1 + bcl 20,31,$+4 + mflr 1 + ld 1,eregs-$+4(1) # GPR1 = address of register save area + + .irp i, 2,3,4,5,6,7,8,9,10,11,12,13,14,15, \ + 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31 + std \i,\i*8(1) + .endr # save GPR2..GPR31 + + li r3, 3 // GPR3 = mode (param_1, param_2) + mr 4,0 // GPR4 = vector + + mfsprg 0,0 + std 0,0(1) # save GPR0 + mfsprg 0,1 + std 0,8(1) # save GPR1 + + cmpwi r4, 0x900 # Decrementer interrupt + bne 0f + mfdec r5 # Save old value of decrementer as reason + lis r0,0x7fff # Set decrementer to highest value + mtdec r0 +0: + mfcr 0 + std 0,0x100(1) + mfxer 0 + std 0,0x108(1) + mfsprg 0,3 # save lr + std 0,0x110(1) + mfsprg 0,2 # save ctr + std 0,0x118(1) + mfsrr0 0 + std 0,0x120(1) + mfsrr1 0 + std 0,0x128(1) + mfdar 0 + std 0,0x130(1) + mfdsisr 0 + std 0,0x138(1) # save special regs + + bcl 20, 31, over +base: + .align 3 +.the_system_stack: + .quad the_system_stack+STACKSIZE-base +over: + mflr r2 /* gpr 2 is the base */ + ld r1, .the_system_stack-base(r2) /* load stack pointer */ + add r1, r1, r2 /* add base */ + li r0, 0 + stdu r0, -0x10(r1) + stdu r1, -0x100(r1) + + lis 2,engine@ha + ld 0,engine@l(2) # set up entry + mtsrr0 0 + + ld 2,8+engine@l(2) # set up TOC pointer + + rfid +# b .engine # ...and run! + + + + # + # Swap non-volatile client interface regs, plus GPR3..GPR7. + # + +swap_ci_regs: + /* save lr */ + mflr r0 + /* let's find out where our client stack is */ + bcl 20, 31, client_over +client_base: + .align 3 +.the_client_frame: + .quad the_client_frame-client_base +client_over: + mflr r8 /* gpr 2 is the client_base */ + mtlr r0 /* restore the original lr */ + ld r0, .the_client_frame-client_base(r8) + add r8, r0, r8 /* add the client_base */ + /* r8 now contains the address of the_client_frame */ + + .irp i, 1,2,3,4,5,6,7, \ + 13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31 + ld 0,\i*8(8) + std \i,\i*8(8) + mr \i,0 + .endr # swap GPR1..7, GPR13..31 + + ld 0,0x100(8) + mfcr 9 + mtcrf 0xff,0 + std 9,0x100(8) # swap CR + + ld 0,0x128(8) + mfmsr 9 + mtmsrd 0 + sync + isync + std 9,0x128(8) # swap MSR + + blr + + # + # Entry point for the OF client interface. + # + + .globl client_entry_point + .section ".opd","aw" + .align 3 +client_entry_point: + .quad .client_entry_point,.TOC.@tocbase,0 + .previous + .type .client_entry_point,@function + .globl .client_entry_point +.client_entry_point: + mflr 4 + bl swap_ci_regs # swap regs + mtlr 4 + li 3, 0 # client call + blr + + # + # Start the client. + # + + .globl call_client + .section ".opd","aw" + .align 3 +call_client: + .quad .call_client,.TOC.@tocbase,0 + .previous + .type .call_client,@function + .globl .call_client + +.call_client: # called with r3 = address, returns r3 + mflr 4 + mtctr 3 + bl swap_ci_regs + /* Check if LE loading */ + cmpwi 0,13,1 + beq 0f + bctrl + b 1f +0: /* handle LE */ + mfmsr 13 + xori 13,13,1 + mtsrr1 13 + mfctr 13 + mr 12,13 + mtsrr0 13 + rfid +#if 0 /* in case we return back, still to be tested */ + .long 0x05009f42; /* bcl 20,31,$+4 */ + .long 0xa602c87d; /* mflr r14 */ + .long 0x1c00ce39; /* addi r14,r14,28 */ + .long 0xa600e07d; /* mfmsr r15 */ + .long 0x0100ef69; /* xori r15,r15,1 */ + .long 0xa603da7d; /* mtsrr0 r14 */ + .long 0xa603fb7d; /* mtsrr1 r15 */ + .long 0x2400004c; /* rfid */ +#endif +1: + bl swap_ci_regs + mtlr 4 + li 3, -1 # client app return + blr + + + # Call another function via pointer in r6 + # (arguments can be provided in r3 to r5) + # Destination function should jump back to lr +C_ENTRY(call_c) + mtctr r6 + bctr + + + .lcomm the_system_stack, STACKSIZE, 16 diff --git a/src/roms/SLOF/slof/fs/accept.fs b/src/roms/SLOF/slof/fs/accept.fs new file mode 100644 index 0000000..7e8e271 --- /dev/null +++ b/src/roms/SLOF/slof/fs/accept.fs @@ -0,0 +1,410 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Implementation of ACCEPT. Using ECMA-48 for terminal control. + +: beep bell emit ; + +: TABLE-EXECUTE + CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ; + +0 VALUE accept-adr +0 VALUE accept-max +0 VALUE accept-len +0 VALUE accept-cur + +: esc 1b emit ; +: csi esc 5b emit ; + +: move-cursor ( -- ) + esc ." 8" accept-cur IF + csi base @ decimal accept-cur 0 .r base ! ." C" + THEN +; + +: redraw-line ( -- ) + accept-cur accept-len = IF EXIT THEN + move-cursor + accept-adr accept-len accept-cur /string type + csi ." K" move-cursor +; + +: full-redraw-line ( -- ) + accept-cur 0 to accept-cur move-cursor + accept-adr accept-len type + csi ." K" to accept-cur move-cursor +; + +: redraw-prompt ( -- ) + cr depth . [char] > emit +; + +: insert-char ( char -- ) + accept-len accept-max = IF drop beep EXIT THEN + accept-cur accept-len <> IF csi ." @" dup emit + accept-adr accept-cur + dup 1+ accept-len accept-cur - move + ELSE dup emit THEN + accept-adr accept-cur + c! + accept-cur 1+ to accept-cur + accept-len 1+ to accept-len redraw-line +; + +: delete-char ( -- ) + accept-cur accept-len = IF beep EXIT THEN + accept-len 1- to accept-len + accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move + csi ." P" redraw-line +; + +\ * +\ * History handling +\ * + +STRUCT +cell FIELD his>next +cell FIELD his>prev +cell FIELD his>len + 0 FIELD his>buf +CONSTANT /his +0 VALUE his-head +0 VALUE his-tail +0 VALUE his-cur + +: add-history ( -- ) + accept-len 0= IF EXIT THEN + /his accept-len + alloc-mem + his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN + his-tail over his>prev ! 0 over his>next ! dup to his-tail + accept-len over his>len ! accept-adr swap his>buf accept-len move +; + +: history ( -- ) + his-head BEGIN dup WHILE + cr dup his>buf over his>len @ type + his>next @ REPEAT drop +; + +: select-history ( his -- ) + dup to his-cur dup IF + dup his>len @ accept-max min dup to accept-len to accept-cur + his>buf accept-adr accept-len move ELSE + drop 0 to accept-len 0 to accept-cur THEN + full-redraw-line +; + + +\ +\ tab completion +\ + +\ tab completion state variables +0 value ?tab-pressed +0 value tab-last-adr +0 value tab-last-len + +\ compares two strings and returns the longest equal substring. +: $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' ) + dup 0= IF \ The second parameter is not a string. + 2drop EXIT \ bail out + THEN + rot min 0 0 -rot ( addr1 addr2 0 len' 0 ) + DO ( addr1 addr2 len-1' ) + 2 pick i + c@ lcc + 2 pick i + c@ lcc + = IF 1 + ELSE leave THEN + LOOP + nip +; + +: $tab-sift-words ( text-addr text-len -- sift-count ) + sift-compl-only >r true to sift-compl-only \ save sifting mode + + last BEGIN @ ?dup WHILE \ loop over all words + $inner-sift IF \ any completions possible? + \ convert to lower case for user interface sanity + 2dup bounds DO I c@ lcc I c! LOOP + ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities + tab-last-adr tab-last-len $same-string \ find matching substring ... + to tab-last-len to tab-last-adr \ ... and save it + THEN + repeat + 2drop + + #sift-count 0 to #sift-count \ how many words were found? + r> to sift-compl-only \ restore sifting completion mode +; + +\ 8< node sifting for tab completion on device tree nodes below this line 8< + +#include <stack.fs> + +10 new-stack device-stack + +: (next-dev) ( node -- node' addr len ) + device-stack + dup (node>path) rot + dup child IF dup push child -rot EXIT THEN + dup peer IF peer -rot EXIT THEN + drop + BEGIN + stack-depth + WHILE + pop peer ?dup IF -rot EXIT THEN + REPEAT + 0 -rot +; + +: $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false ) + (next-dev) ( text-addr text-len node' path-addr path-len ) + dup 0= IF drop false EXIT THEN + 2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos ) + 0= IF + #sift-count 1+ to #sift-count \ count completions + true + ELSE + 2drop false + THEN +; + +\ +\ test function for (next-dev) +: .nodes ( -- ) + s" /" find-node BEGIN dup WHILE + (next-dev) + type cr + REPEAT + drop + reset-stack +; + +\ node sifting wants its own pockets +create sift-node-buffer 1000 allot +0 value sift-node-num +: sift-node-buffer + sift-node-buffer sift-node-num 100 * + + sift-node-num 1+ dup 10 = IF drop 0 THEN + to sift-node-num +; + +: $tab-sift-nodes ( text-addr text-len -- sift-count ) + s" /" find-node BEGIN dup WHILE + $inner-sift-nodes IF \ any completions possible? + sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup + ?tab-pressed IF 2dup type space THEN \ <tab><tab> prints possibilities + tab-last-adr tab-last-len $same-string \ find matching substring ... + to tab-last-len to tab-last-adr \ ... and save it + THEN + REPEAT + 2drop drop + #sift-count 0 to #sift-count \ how many words were found? + reset-stack +; + +: $tab-sift ( text-addr text-len -- sift-count ) + ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab> + + dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r + + 0 dup to tab-last-len to tab-last-adr \ reset last possible match + current-node @ IF \ if we are in a node? + 2dup 2>r \ save text + $tab-sift-words to #sift-count \ search in current node first + 2r> \ fetch text to complete, again + THEN + 2dup 2>r + current-node @ >r 0 set-node \ now search in global words + $tab-sift-words to #sift-count + r> set-node + 2r> $tab-sift-nodes + \ concatenate previous commands + r> r> dup IF s" " $cat THEN tab-last-adr tab-last-len $cat + to tab-last-len to tab-last-adr \ ... and save the whole string +; + +\ 8< node sifting for tab completion on device tree nodes above this line 8< + +: handle-^A + 0 to accept-cur move-cursor ; +: handle-^B + accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ; +: handle-^D + delete-char ( redraw-line ) ; +: handle-^E + accept-len to accept-cur move-cursor ; +: handle-^F + accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ; +: handle-^H + accept-cur 0= IF beep EXIT THEN + handle-^B delete-char +; +: handle-^I + accept-adr accept-len + $tab-sift 0 > IF + ?tab-pressed IF + redraw-prompt full-redraw-line + false to ?tab-pressed + ELSE + tab-last-adr accept-adr tab-last-len move \ copy matching substring + tab-last-len dup to accept-len to accept-cur \ len and cursor position + full-redraw-line \ redraw new string + true to ?tab-pressed \ second tab will print possible matches + THEN + THEN +; + +: handle-^K + BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ; +: handle-^L + history redraw-prompt full-redraw-line ; +: handle-^N + his-cur IF his-cur his>next @ ELSE his-head THEN + dup to his-cur select-history +; +: handle-^P + his-cur IF his-cur his>prev @ ELSE his-tail THEN + dup to his-cur select-history +; +: handle-^Q \ Does not handle terminal formatting yet. + key insert-char ; +: handle-^R + full-redraw-line ; +: handle-^U + 0 to accept-len 0 to accept-cur full-redraw-line ; + +: handle-fn + key drop beep +; + +TABLE-EXECUTE handle-CSI +0 , ' handle-^P , ' handle-^N , ' handle-^F , +' handle-^B , 0 , 0 , 0 , +' handle-^A , 0 , 0 , ' handle-^E , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , + +TABLE-EXECUTE handle-meta +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , ' handle-fn , +0 , 0 , 0 , 0 , +0 , 0 , 0 , 0 , +0 , 0 , 0 , ' handle-CSI , +0 , 0 , 0 , 0 , + +: handle-ESC-O + key + dup 48 = IF + handle-^A + ELSE + dup 46 = IF + handle-^E + THEN + THEN drop +; + +: handle-ESC-5b + key + dup 31 = IF \ HOME + key drop ( drops closing 7e ) handle-^A + ELSE + dup 33 = IF \ DEL + key drop handle-^D + ELSE + dup 34 = IF \ END + key drop handle-^E + ELSE + dup 1f and handle-CSI + THEN + THEN + THEN drop +; + +: handle-ESC + key + dup 5b = IF + handle-ESC-5b + ELSE + dup 4f = IF + handle-ESC-O + ELSE + dup 1f and handle-meta + THEN + THEN drop +; + +TABLE-EXECUTE handle-control +0 , \ ^@: +' handle-^A , +' handle-^B , +0 , \ ^C: +' handle-^D , +' handle-^E , +' handle-^F , +0 , \ ^G: +' handle-^H , +' handle-^I , \ tab +0 , \ ^J: +' handle-^K , +' handle-^L , +0 , \ ^M: enter: handled in main loop +' handle-^N , +0 , \ ^O: +' handle-^P , +' handle-^Q , +' handle-^R , +0 , \ ^S: +0 , \ ^T: +' handle-^U , +0 , \ ^V: +0 , \ ^W: +0 , \ ^X: +0 , \ ^Y: insert save buffer +0 , \ ^Z: +' handle-ESC , +0 , \ ^\: +0 , \ ^]: +0 , \ ^^: +0 , \ ^_: + +: (accept) ( adr len -- len' ) + cursor-on + to accept-max to accept-adr + 0 to accept-len 0 to accept-cur + 0 to his-cur + 1b emit 37 emit + BEGIN + key dup 0d <> + WHILE + dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine + dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus + dup bl < IF handle-control ELSE + dup 80 and IF + dup a0 < IF 7f and handle-meta ELSE drop beep THEN + ELSE + insert-char + THEN + THEN + REPEAT + drop add-history + accept-len to accept-cur + move-cursor space + accept-len + cursor-off +; + +' (accept) to accept + diff --git a/src/roms/SLOF/slof/fs/alloc-mem-debug.fs b/src/roms/SLOF/slof/fs/alloc-mem-debug.fs new file mode 100644 index 0000000..d4ca70b --- /dev/null +++ b/src/roms/SLOF/slof/fs/alloc-mem-debug.fs @@ -0,0 +1,116 @@ +\ ***************************************************************************** +\ * Copyright (c) 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ * Dynamic memory allocation/de-allocation debug functions +\ ***************************************************************************** + + +\ Uncomment the following code for debugging bad write accesses beyond +\ the end of the allocated block: +\ Store magic value past the end of the block during alloc-mem and +\ check for this magic value when free-mem has been called. +#if 1 +: alloc-mem ( len -- addr ) + dup /n + alloc-mem ( len addr ) + 2dup + 3141592653589793 swap ! nip +; + +: free-mem ( addr len -- ) + 2dup + @ 3141592653589793 <> IF + cr ." Detected memory corrupt during free-mem of " + swap . . cr EXIT + THEN + /n + free-mem +; +#endif + + +\ Never ever assume that allocated memory is pre-initialized with 0 ... +: alloc-mem ( len -- addr ) + dup alloc-mem swap 2dup ff fill drop +; + +\ Make sure that memory block do not contain "valid" data after free-mem: +: free-mem ( addr len -- ) + 2dup ff fill free-mem +; + + +\ The following definitions are used for debugging the parameters of free-mem: +\ Store block address and size of allocated blocks +\ in an array, then check for right values on free-mem. + +1000 CONSTANT max-malloced-blocks +CREATE malloced-blocks max-malloced-blocks 2 * cells allot +malloced-blocks max-malloced-blocks 2 * cells erase + + +: alloc-mem ( len -- addr ) + dup alloc-mem dup 0= IF + cr ." alloc-mem returned 0 for size " swap . cr EXIT + THEN ( len addr ) + malloced-blocks max-malloced-blocks 0 DO ( len addr m-blocks-ptr ) + dup @ 0= IF ( len addr m-blocks-ptr ) + \ Found a free entry: store addr and len + over >r dup >r ! + r> cell+ ! + r> UNLOOP EXIT + THEN + cell+ cell+ ( len addr next-m-blocks-ptr ) + LOOP + ." Please increase max-malloced-blocks." cr ( len addr next-m-blocks-ptr ) + drop nip +; + + +: free-mem ( addr len -- ) + malloced-blocks max-malloced-blocks 0 DO ( addr len m-blocks-ptr ) + dup @ ?dup IF + ( addr len m-blocks-ptr s-addr ) + 3 pick = IF + ( addr len m-blocks-ptr ) + dup cell+ @ ( addr len m-blocks-ptr s-len ) + 2 pick = IF ( addr len m-blocks-ptr ) + \ All right, addr and len matched, + \ clear entry and call original free-mem. + dup cell+ 0 swap ! + 0 swap ! + free-mem + ELSE + >r swap cr + ." free-mem called for block " . ." with wrong size=" . cr + ." ( correct size should be: " r> cell+ @ . ." )" cr + THEN + UNLOOP EXIT + THEN ( addr len m-blocks-ptr ) + THEN + cell+ cell+ ( addr len next-m-blocks-ptr ) + LOOP + drop swap cr + ." free-mem called for block " . + ." ( size=" . + ." ) which has never been allocated before!" cr +; + + +\ Enable these for verbose debug messages: +#if 0 +: alloc-mem + cr ." alloc-mem with len=" dup . + alloc-mem + ." returned addr=" dup . cr +; + +: free-mem + cr ." free mem addr=" over . ." len=" dup . cr + free-mem +; +#endif diff --git a/src/roms/SLOF/slof/fs/alloc-mem.fs b/src/roms/SLOF/slof/fs/alloc-mem.fs new file mode 100644 index 0000000..59381a7 --- /dev/null +++ b/src/roms/SLOF/slof/fs/alloc-mem.fs @@ -0,0 +1,75 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +#include <claim.fs> +\ Memory "heap" (de-)allocation. + +\ Keep a linked list of free blocks per power-of-two size. +\ Never coalesce entries when freed; split blocks when needed while allocating. + +\ 3f CONSTANT (max-heads#) +heap-end heap-start - log2 1+ CONSTANT (max-heads#) + +CREATE heads (max-heads#) cells allot +heads (max-heads#) cells erase + + +: size>head ( size -- headptr ) log2 3 max cells heads + ; + + +\ Allocate a memory block +: alloc-mem ( len -- a-addr ) + dup 0= IF EXIT THEN + 1 over log2 3 max ( len 1 log_len ) + dup (max-heads#) >= IF cr ." Out of internal memory." cr 3drop 0 EXIT THEN + lshift >r ( len R: 1<<log_len ) + size>head dup @ IF + dup @ dup >r @ swap ! r> r> drop EXIT + THEN ( headptr R: 1<<log_len) + r@ 2* recurse dup ( headptr a-addr2 a-addr2 R: 1<<log_len) + dup 0= IF r> 2drop 2drop 0 EXIT THEN + r> + >r 0 over ! swap ! r> +; + + +\ Free a memory block + +: free-mem ( a-addr len -- ) + dup 0= IF 2drop EXIT THEN size>head 2dup @ swap ! ! +; + + +: #links ( a -- n ) + @ 0 BEGIN over WHILE 1+ swap @ swap REPEAT nip +; + + +: .free ( -- ) + 0 (max-heads#) 0 DO + heads i cells + #links dup IF + cr dup . ." * " 1 i lshift dup . ." = " * dup . + THEN + + + LOOP + cr ." Total " . +; + + +\ Start with just one free block. +heap-start heap-end heap-start - free-mem + + +\ : free-mem ( a-addr len -- ) 2drop ; + +\ Uncomment the following line for debugging: +\ #include <alloc-mem-debug.fs> + diff --git a/src/roms/SLOF/slof/fs/archsupport.fs b/src/roms/SLOF/slof/fs/archsupport.fs new file mode 100644 index 0000000..f564ab4 --- /dev/null +++ b/src/roms/SLOF/slof/fs/archsupport.fs @@ -0,0 +1,38 @@ +\ ***************************************************************************** +\ * Copyright (c) 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ 128KB FDT buffer size is enough to accommodate 255 CPU cores and 1TB of +\ maxmem specification. +20000 VALUE size +: ibm,client-architecture-support ( vec -- err? ) + \ Store require parameters in nvram + \ to come back to right boot device + \ Allocate memory for H_CALL + size alloc-mem ( vec memaddr ) + swap over size ( memaddr vec memaddr size ) + \ make h_call to hypervisor + hv-cas 0= IF ( memaddr ) + dup l@ 1 >= IF \ Version number >= 1 + \ Make required changes + " /" find-node set-node + dup 4 + fdt-init + fdt-check-header + fdt-struct fdt-fix-cas-node + fdt-fix-cas-success NOT + ELSE + FALSE + THEN + ELSE + TRUE + THEN + >r size free-mem r> +; diff --git a/src/roms/SLOF/slof/fs/available.fs b/src/roms/SLOF/slof/fs/available.fs new file mode 100644 index 0000000..5eb8fa9 --- /dev/null +++ b/src/roms/SLOF/slof/fs/available.fs @@ -0,0 +1,72 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +VARIABLE chosen-memory-ih 0 chosen-memory-ih ! + +\ + +\ Maintain "available" property. +\ Sun has a single memory node with "available" property +\ and separate memory controller nodes. +\ We corespond memory nodes with their respective memory controllers +\ and use /chosen/memory as default memory node to hold the "available" map +\ NOTE -> /chosen/memory is expected 2B initialized before using claim/release +\ + + +: (chosen-memory-ph) ( -- phandle ) + chosen-memory-ih @ ?dup 0= IF + s" memory" get-chosen IF + decode-int nip nip dup chosen-memory-ih ! + ihandle>phandle + ELSE 0 THEN + ELSE ihandle>phandle THEN +; + +: (set-available-prop) ( prop plen -- ) + s" available" + (chosen-memory-ph) ?dup 0<> IF set-property ELSE + cr ." Can't find chosen memory node - " + ." no available property created" cr + 2dup 2dup + THEN +; + +: update-available-property ( available-ptr -- ) + dup >r available>size@ + 0= r@ available AVAILABLE-SIZE /available * + >= or IF + available r> available - encode-bytes (set-available-prop) + ELSE + r> /available + RECURSE + THEN +; + +: update-available-property available update-available-property ; + +\ \\\\\\\\\\\\\\ Exported Interface: +\ + +\ IEEE 1275 implementation: +\ claim +\ Claim the region with given start address and size (if align parameter is 0); +\ alternatively claim any region of given alignment +\ + +\ Throw an exception if failed +\ + +: claim ( [ addr ] len align -- base ) claim update-available-property ; + +\ + +\ IEEE 1275 implementation: +\ release +\ Free the region with given start address and size +\ + +: release ( addr len -- ) release update-available-property ; + +update-available-property + diff --git a/src/roms/SLOF/slof/fs/banner.fs b/src/roms/SLOF/slof/fs/banner.fs new file mode 100644 index 0000000..efdba0c --- /dev/null +++ b/src/roms/SLOF/slof/fs/banner.fs @@ -0,0 +1,23 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: banner + cr ." Type 'boot' and press return to continue booting the system." + s" /packages/sms" find-node IF + cr ." Type 'sms-start' and press return to enter the configuration menu." + THEN + cr ." Type 'reset-all' and press return to reboot the system." + cr cr +; + +: .banner banner console-clean-fifo ; + diff --git a/src/roms/SLOF/slof/fs/base.fs b/src/roms/SLOF/slof/fs/base.fs new file mode 100644 index 0000000..03e77e5 --- /dev/null +++ b/src/roms/SLOF/slof/fs/base.fs @@ -0,0 +1,609 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Hash for faster lookup +#include <find-hash.fs> + +: >name ( xt -- nfa ) \ note: still has the "immediate" field! + BEGIN char- dup c@ UNTIL ( @lastchar ) + dup dup aligned - cell+ char- ( @lastchar lenmodcell ) + dup >r - + BEGIN dup c@ r@ <> WHILE + cell- r> cell+ >r + REPEAT + r> drop char- +; + +\ Words missing in *.in files +VARIABLE mask -1 mask ! + +VARIABLE huge-tftp-load 1 huge-tftp-load ! +\ Default implementation for sms-get-tftp-blocksize that return 1432 (decimal) +: sms-get-tftp-blocksize 598 ; + +: default-hw-exception s" Exception #" type . ; + +' default-hw-exception to hw-exception-handler + +: diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs + +: memory-test-suite ( addr len -- fail? ) + diagnostic-mode? IF + ." Memory test mask value: " mask @ . cr + ." No memory test suite currently implemented! " cr + THEN + false +; + +: 0.r 0 swap <# 0 ?DO # LOOP #> type ; + +\ count the number of bits equal 1 +\ the idea is to clear in each step the least significant bit +\ v&(v-1) does exactly this, so count the steps until v == 0 +: cnt-bits ( 64-bit-value -- #bits=1 ) + dup IF + 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP + THEN +; + +: bcd-to-bin ( bcd -- bin ) + dup f and swap 4 rshift a * + +; + +\ calcs the exponent of the highest power of 2 not greater than n +: 2log ( n -- lb{n} ) + 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP +; + +\ calcs the exponent of the lowest power of 2 not less than n +: log2 ( n -- log2-n ) + 1- 2log 1+ +; + + +CREATE $catpad 400 allot +: $cat ( str1 len1 str2 len2 -- str3 len3 ) + >r >r dup >r $catpad swap move + r> dup $catpad + r> swap r@ move + r> + $catpad swap ; + +\ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense +\ that they add 1 or 2 characters to str1 before executing $cat +\ The ASSUMPTION is that str1 buffer provides that extra space and it is +\ responsibility of the code owner to ensure that +: $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 ) + 2dup + s" , " rot swap move 2+ 2swap $cat +; + +: $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 ) + 2dup + bl swap c! 1+ 2swap $cat +; +: $cathex ( str len val -- str len' ) + (u.) $cat +; + + +: 2CONSTANT CREATE , , DOES> [ here ] 2@ ; + +\ Save XT of 2CONSTANT, put on the stack by "[ here ]" : +CONSTANT <2constant> + +: $2CONSTANT $CREATE , , DOES> 2@ ; + +: 2VARIABLE CREATE 0 , 0 , DOES> ; + + +: (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ; + +: zplace ( str len buf -- ) 2dup + 0 swap c! swap move ; +: rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ; + +: strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ; + +: str= ( str1 len1 str2 len2 -- equal? ) + rot over <> IF 3drop false ELSE comp 0= THEN ; + +: test-string ( param len -- true | false ) + 0 ?DO + dup i + c@ \ Get character / byte at current index + dup 20 < swap 7e > OR IF \ Is it out of range 32 to 126 (=ASCII) + drop FALSE UNLOOP EXIT \ FALSE means: No ASCII string + THEN + LOOP + drop TRUE \ Only ASCII found --> it is a string +; + +: #aligned ( adr alignment -- adr' ) negate swap negate and negate ; +: #join ( lo hi #bits -- x ) lshift or ; +: #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ; + +: /string ( str len u -- str' len' ) + >r swap r@ chars + swap r> - ; +: skip ( str len c -- str' len' ) + >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ; +: scan ( str len c -- str' len' ) + >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ; +: split ( str len char -- left len right len ) + >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ; +\ reverse findchar -- search from the end of the string +: rfindchar ( str len char -- offs true | false ) + swap 1 - 0 swap do + over i + c@ + over dup bl = if <= else = then if + 2drop i dup dup leave + then + -1 +loop = +; +\ reverse split -- split at the last occurrence of char +: rsplit ( str len char -- left len right len ) + >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ; + +: left-parse-string ( str len char -- R-str R-len L-str L-len ) + split 2swap ; +: replace-char ( str len chout chin -- ) + >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT + r> 2drop 2drop +; +\ Duplicate string and replace \ with / +: \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ; + +: isdigit ( char -- true | false ) + 30 39 between +; + +: ishexdigit ( char -- true | false ) + 30 39 between 41 46 between OR 61 66 between OR +; + +\ Variant of $number that defaults to decimal unless "0x" is +\ a prefix +: $dh-number ( addr len -- true | number false ) + base @ >r + decimal + dup 2 > IF + over dup c@ [char] 0 = + over 1 + c@ 20 or [char] x = + AND IF hex 2 + swap 2 - rot THEN drop + THEN + $number + r> base ! +; + +: // dup >r 1- + r> / ; \ division, round up + +: c@+ ( adr -- c adr' ) dup c@ swap char+ ; +: 2c@ ( adr -- c1 c2 ) c@+ c@ ; +: 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ; +: 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ; + + +: 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ; +: 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ; + +\ yes sometimes even something like this is needed +: 5dup ( 1 2 3 4 5 -- 1 2 3 4 5 1 2 3 4 5 ) + 4 pick 4 pick 4 pick 4 pick 4 pick ; +: 5drop 4drop drop ; +: 5nip + nip nip nip nip nip ; + +: 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 ) + 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ; + +\ convert a 32 bit signed into a 64 signed +\ ( propagate bit 31 to all bits 32:63 ) +: signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ; + +: <l@ ( addr -- x ) l@ signed ; + +: -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ; +: (parse-line) skipws 0 parse ; + + +\ Append two character to hex byte, if possible + +: hex-byte ( char0 char1 -- value true|false ) + 10 digit IF + swap 10 digit IF + 4 lshift or true EXIT + ELSE + 2drop 0 + THEN + ELSE + drop + THEN + false EXIT +; + +\ Parse hex string within brackets + +: parse-hexstring ( dst-adr -- dst-adr' ) + [char] ) parse cr ( dst-adr str len ) + bounds ?DO ( dst-adr ) + i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte ) + >r dup r> swap c! 1+ 2 ( dst-adr+1 2 ) + ELSE + drop 1 ( dst-adr 1 ) + THEN + +LOOP +; + +\ Add special character to string + +: add-specialchar ( dst-adr special -- dst-adr' ) + over c! 1+ ( dst-adr' ) + 1 >in +! \ advance input-index +; + +\ Parse up to next " + +: parse-" ( dst-adr -- dst-adr' ) + [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' ) + >r swap r> move r> ( dst-adr' ) +; + +: (") ( dst-adr -- dst-adr' ) + begin ( dst-adr ) + parse-" ( dst-adr' ) + >in @ dup span @ >= IF ( dst-adr' >in-@ ) + drop + EXIT + THEN + + ib + c@ + CASE + [char] ( OF parse-hexstring ENDOF + [char] " OF [char] " add-specialchar ENDOF + dup OF EXIT ENDOF + ENDCASE + again +; + +CREATE "pad 100 allot + +\ String with embedded hex strings +\ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62< + +: " ( [text<">< >] -- text-str text-len ) + state @ IF \ compile sliteral, pstr into dict + "pad dup (") over - ( str len ) + ['] sliteral compile, dup c, ( str len ) + bounds ?DO i c@ c, LOOP + align ['] count compile, + ELSE + pocket dup (") over - \ Interpretation, put string + THEN \ in temp buffer +; immediate + + +\ Output the carriage-return character +: (cr carret emit ; + + +\ Remove command old-name and all subsequent definitions + +: $forget ( str len -- ) + 2dup last @ ( str len str len last-bc ) + BEGIN + dup >r ( str len str len last-bc R: last-bc ) + cell+ char+ count ( str len str len found-str found-len R: last-bc ) + string=ci IF ( str len R: last-bc ) + r> @ last ! 2drop clean-hash EXIT ( -- ) + THEN + 2dup r> @ dup 0= ( str len str len next-bc next-bc ) + UNTIL + drop 2drop 2drop \ clean hash table +; + +: forget ( "old-name<>" -- ) + parse-word $forget +; + +#include <search.fs> + +\ The following constants are required in some parts +\ of the code, mainly instance variables and see. Having to reverse +\ engineer our own CFAs seems somewhat weird, but we gained a bit speed. + +\ Each colon definition is surrounded by colon and semicolon +\ constant below contain address of their xt + +: (function) ; +defer (defer) +0 value (value) +0 constant (constant) +variable (variable) +create (create) +alias (alias) (function) +cell buffer: (buffer:) + +' (function) @ \ ( <colon> ) +' (function) cell + @ \ ( ... <semicolon> ) +' (defer) @ \ ( ... <defer> ) +' (value) @ \ ( ... <value> ) +' (constant) @ \ ( ... <constant> ) +' (variable) @ \ ( ... <variable> ) +' (create) @ \ ( ... <create> ) +' (alias) @ \ ( ... <alias> ) +' (buffer:) @ \ ( ... <buffer:> ) + +\ now clean up the test functions +forget (function) + +\ and remember the constants +constant <buffer:> +constant <alias> +constant <create> +constant <variable> +constant <constant> +constant <value> +constant <defer> +constant <semicolon> +constant <colon> + +' lit constant <lit> +' sliteral constant <sliteral> +' 0branch constant <0branch> +' branch constant <branch> +' doloop constant <doloop> +' dotick constant <dotick> +' doto constant <doto> +' do?do constant <do?do> +' do+loop constant <do+loop> +' do constant <do> +' exit constant <exit> +' doleave constant <doleave> +' do?leave constant <do?leave> + + +\ provide the memory management words +\ #include <claim.fs> +\ #include "memory.fs" +#include <alloc-mem.fs> + +#include <node.fs> + +: find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos ) + \ if substr-len == 0 ? + dup 0 = IF + \ return 0 + 2drop 2drop 0 exit THEN + \ if substr-len <= basestr-len ? + dup 3 pick <= IF + \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1 + 2 pick over - 1+ 0 DO dup 0 DO + \ substr-ptr[i] == basestr-ptr[j+i] ? + over i + c@ 4 pick j + i + c@ = IF + \ (I+1) == substr-len ? + dup i 1+ = IF + \ return J + 2drop 2drop j unloop unloop exit THEN + ELSE leave THEN + LOOP LOOP + THEN + \ if there is no match then exit with basestr-len as return value + 2drop nip +; + +: find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos ) + \ if substr-len == 0 ? + dup 0 = IF + \ return 0 + 2drop 2drop 0 exit THEN + \ if substr-len <= basestr-len ? + dup 3 pick <= IF + \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1 + 2 pick over - 1+ 0 DO dup 0 DO + \ substr-ptr[i] == basestr-ptr[j+i] ? + over i + c@ lcc 4 pick j + i + c@ lcc = IF + \ (I+1) == substr-len ? + dup i 1+ = IF + \ return J + 2drop 2drop j unloop unloop exit THEN + ELSE leave THEN + LOOP LOOP + THEN + \ if there is no match then exit with basestr-len as return value + 2drop nip +; + +: find-nextline ( str-ptr str-len -- pos ) + \ run I from 0 to "str-len"-1 and check str-ptr[i] + dup 0 ?DO over i + c@ CASE + \ 0x0a (=LF) found ? + 0a OF + \ if current cursor is at end position (I == "str-len"-1) ? + dup 1- i = IF + \ return I+1 + 2drop i 1+ unloop exit THEN + \ if str-ptr[I+1] == 0x0d (=CR) ? + over i 1+ + c@ 0d = IF + \ return I+2 + 2drop i 2+ ELSE + \ else return I+1 + 2drop i 1+ THEN + unloop exit + ENDOF + \ 0x0d (=CR) found ? + 0d OF + \ if current cursor is at end position (I == "str-len"-1) ? + dup 1- i = IF + \ return I+1 + 2drop i 1+ unloop exit THEN + \ str-ptr[I+1] == 0x0a (=LF) ? + over i 1+ + c@ 0a = IF + \ return I+2 + 2drop i 2+ ELSE + \ return I+1 + 2drop i 1+ THEN + unloop exit + ENDOF + ENDCASE LOOP nip +; + +: string-at ( str1-ptr str1-len pos -- str2-ptr str2-len ) + -rot 2 pick - -rot swap chars + swap +; + +\ appends the string beginning at addr2 to the end of the string +\ beginning at addr1 +\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!! +\ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!! + +: string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 ) + \ len1 := len1+len2 + rot dup >r over + -rot + ( addr1 len1+len2 dest-ptr src-ptr len2 ) + 3 pick r> chars + -rot + ( ... dest-ptr src-ptr ) + 0 ?DO + 2dup c@ swap c! + char+ swap char+ swap + LOOP 2drop +; + +\ appends a character to the end of the string beginning at addr +\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!! +\ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!! + +: char-cat ( addr len character -- addr len+1 ) + -rot 2dup >r >r 1+ rot r> r> chars + c! +; + +\ Returns true if source and destination overlap +: overlap ( src dest size -- true|false ) + 3dup over + within IF 3drop true ELSE rot tuck + within THEN +; + +: parse-2int ( str len -- val.lo val.hi ) +\ ." parse-2int ( " 2dup swap . . ." -- " + [char] , split ?dup IF eval ELSE drop 0 THEN + -rot ?dup IF eval ELSE drop 0 THEN +\ 2dup swap . . ." )" cr +; + +\ peek/poke minimal implementation, just to support FCode drivers +\ Any implmentation with full error detection will be platform specific +: cpeek ( addr -- false | byte true ) c@ true ; +: cpoke ( byte addr -- success? ) c! true ; +: wpeek ( addr -- false | word true ) w@ true ; +: wpoke ( word addr -- success? ) w! true ; +: lpeek ( addr -- false | lword true ) l@ true ; +: lpoke ( lword addr -- success? ) l! true ; + +defer reboot ( -- ) +defer halt ( -- ) +defer disable-watchdog ( -- ) +defer reset-watchdog ( -- ) +defer set-watchdog ( +n -- ) +defer set-led ( type instance state -- status ) +defer get-flashside ( -- side ) +defer set-flashside ( side -- status ) +defer read-bootlist ( -- ) +defer furnish-boot-file ( -- adr len ) +defer set-boot-file ( adr len -- ) +defer mfg-mode? ( -- flag ) +defer of-prompt? ( -- flag ) +defer debug-boot? ( -- flag ) +defer bmc-version ( -- adr len ) +defer cursor-on ( -- ) +defer cursor-off ( -- ) + +: nop-reboot ( -- ) ." reboot not available" abort ; +: nop-halt ( -- ) ." halt not available" abort ; +: nop-disable-watchdog ( -- ) ; +: nop-reset-watchdog ( -- ) ; +: nop-set-watchdog ( +n -- ) drop ; +: nop-set-led ( type instance state -- status ) drop drop drop ; +: nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ; +: nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ; +: nop-read-bootlist ( -- ) ; +: nop-furnish-bootfile ( -- adr len ) s" net:" ; +: nop-set-boot-file ( adr len -- ) 2drop ; +: nop-mfg-mode? ( -- flag ) false ; +: nop-of-prompt? ( -- flag ) false ; +: nop-debug-boot? ( -- flag ) false ; +: nop-bmc-version ( -- adr len ) s" XXXXX" ; +: nop-cursor-on ( -- ) ; +: nop-cursor-off ( -- ) ; + +' nop-reboot to reboot +' nop-halt to halt +' nop-disable-watchdog to disable-watchdog +' nop-reset-watchdog to reset-watchdog +' nop-set-watchdog to set-watchdog +' nop-set-led to set-led +' nop-get-flashside to get-flashside +' nop-set-flashside to set-flashside +' nop-read-bootlist to read-bootlist +' nop-furnish-bootfile to furnish-boot-file +' nop-set-boot-file to set-boot-file +' nop-mfg-mode? to mfg-mode? +' nop-of-prompt? to of-prompt? +' nop-debug-boot? to debug-boot? +' nop-bmc-version to bmc-version +' nop-cursor-on to cursor-on +' nop-cursor-off to cursor-off + +: reset-all reboot ; + +\ load-base is an env. variable now, but it can +\ be overriden temporarily provided users use +\ get-load-base rather than load-base directly +\ +\ default-load-base is set here and can be +\ overriden by the board code. It will be used +\ to set the default value of the envvar "load-base" +\ when booting without a valid nvram + +10000000 VALUE default-load-base +2000000 VALUE flash-load-base +0 VALUE load-base-override + +: get-load-base + load-base-override 0<> IF load-base-override ELSE + " load-base" evaluate + THEN +; + +\ provide first level debug support +#include "debug.fs" +\ provide 7.5.3.1 Dictionary search +#include "dictionary.fs" +\ provide a simple run time preprocessor +#include <preprocessor.fs> + +: $dnumber base @ >r decimal $number r> base ! ; +: (.d) base @ >r decimal (.) r> base ! ; + +\ IP address conversion + +: (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE ) + base @ >r decimal + over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN + [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot + [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot + [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot + $number IF false r> base ! EXIT THEN + true r> base ! +; + +: (ipformat) ( n1 n2 n3 n4 -- str len ) + base @ >r decimal + 0 <# # # # [char] . hold drop # # # [char] . hold + drop # # # [char] . hold drop # # #s #> + r> base ! +; + +: ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ; + + diff --git a/src/roms/SLOF/slof/fs/boot.fs b/src/roms/SLOF/slof/fs/boot.fs new file mode 100644 index 0000000..a0fe29a --- /dev/null +++ b/src/roms/SLOF/slof/fs/boot.fs @@ -0,0 +1,295 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +0 VALUE load-size +0 VALUE go-entry +VARIABLE state-valid false state-valid ! +CREATE go-args 2 cells allot go-args 2 cells erase + +\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods + +: $bootargs + bootargs 2@ ?dup IF + ELSE s" diagnostic-mode?" evaluate and IF s" diag-file" evaluate + ELSE s" boot-file" evaluate THEN THEN +; + +: $bootdev ( -- device-name len ) + bootdevice 2@ dup IF s" " $cat THEN + s" diagnostic-mode?" evaluate IF + s" diag-device" evaluate + ELSE + s" boot-device" evaluate + THEN + $cat \ prepend bootdevice setting from vpd-bootlist + strdup + ?dup 0= IF + disable-watchdog + drop true ABORT" No boot device!" + THEN +; + + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ * +\ * +: set-boot-args ( str len -- ) dup IF strdup ELSE nip dup THEN bootargs 2! ; + +: (set-boot-device) ( str len -- ) + ?dup IF 1+ strdup 1- ELSE drop 0 0 THEN bootdevice 2! +; + +' (set-boot-device) to set-boot-device + +: (add-boot-device) ( str len -- ) \ Concatenate " str" to "bootdevice" + bootdevice 2@ ?dup IF $cat-space ELSE drop THEN set-boot-device +; + +' (add-boot-device) to add-boot-device + +0 value claim-list + +: no-go ( -- ) -64 boot-exception-handler ABORT ; + +defer go ( -- ) + +: go-32 ( -- ) + state-valid @ IF + 0 ciregs >r3 ! 0 ciregs >r4 ! + go-args 2@ go-entry start-elf client-data + claim-list elf-release 0 to claim-list + THEN + -6d boot-exception-handler ABORT +; + +: go-64 ( args len entry r2 -- ) + 0 ciregs >r3 ! 0 ciregs >r4 ! + start-elf64 client-data + claim-list elf-release 0 to claim-list +; + +: set-le ( -- ) + 1 ciregs >r13 ! +; + +: set-be ( -- ) + 0 ciregs >r13 ! +; + +: go-64-be ( -- ) + state-valid @ IF + set-be + go-args 2@ + go-entry @ + go-entry 8 + @ + go-64 + THEN + -6d boot-exception-handler ABORT +; + + +: go-32-be + set-be + go-32 +; + +: go-32-lev1 + set-le + go-32 +; + +: go-64-lev1 + state-valid @ IF + go-args 2@ + go-entry @ xbflip + go-entry 8 + @ xbflip + set-le + go-64 + THEN + -6d boot-exception-handler ABORT +; + +: go-64-lev2 + state-valid @ IF + go-args 2@ + go-entry 0 + set-le + go-64 + THEN + -6d boot-exception-handler ABORT +; + +: load-elf-init ( arg len file-addr -- success ) + false state-valid ! \ Not valid anymore ... + claim-list IF \ Release claimed mem + claim-list elf-release 0 to claim-list \ from last load + THEN + + true swap -1 ( arg len true file-addr -1 ) + elf-load-claim ( arg len true claim-list entry elftype ) + + ( arg len true claim-list entry elftype ) + CASE + 1 OF ['] go-32-be ENDOF ( arg len true claim-list entry go ) + 2 OF ['] go-64-be ENDOF ( arg len true claim-list entry go ) + 3 OF ['] go-64-lev1 ENDOF ( arg len true claim-list entry go ) + 4 OF ['] go-64-lev2 ENDOF ( arg len true claim-list entry go ) + 5 OF ['] go-32-lev1 ENDOF ( arg len true claim-list entry go ) + dup OF ['] no-go to go + 2drop 3drop false EXIT ENDOF ( false ) + ENDCASE + + to go to go-entry to claim-list + dup state-valid ! -rot + + 2 pick IF + go-args 2! + ELSE + 2drop + THEN +; + +: init-program ( -- ) + $bootargs get-load-base ['] load-elf-init CATCH ?dup IF + boot-exception-handler + 2drop 2drop false \ Could not claim + ELSE IF + 0 ciregs 2dup >r3 ! >r4 ! \ Valid (ELF ) Image + THEN + THEN +; + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ Generic device load method: +\ * + +: do-load ( devstr len -- img-size ) \ Device method wrapper + use-load-watchdog? IF + \ Set watchdog timer to 10 minutes, multiply with 2 because DHCP + \ needs 1 second per try and add 1 min to avoid race conditions + \ with watchdog timeout. + 4ec set-watchdog + THEN + my-self >r current-node @ >r \ Save my-self + ." Trying to load: " $bootargs type ." from: " 2dup type ." ... " + 2dup open-dev dup IF + dup to my-self + dup ihandle>phandle set-node + -rot ( ihandle devstr len ) + encode-string s" bootpath" set-chosen + $bootargs encode-string s" bootargs" set-chosen + get-load-base s" load" 3 pick ['] $call-method CATCH IF + -67 boot-exception-handler 3drop drop false + ELSE + dup 0> IF + init-program + ELSE + false state-valid ! + drop 0 \ Could not load + THEN + THEN + swap close-dev device-end dup to load-size + ELSE -68 boot-exception-handler 3drop false THEN + r> set-node r> to my-self \ Restore my-self +; + +: parse-load ( "{devlist}" -- success ) \ Parse-execute boot-device list + cr BEGIN parse-word dup WHILE + de-alias do-load dup 0< IF drop 0 THEN IF + state-valid @ IF ." Successfully loaded" cr THEN + true 0d parse strdup load-list 2! EXIT + THEN + REPEAT 2drop 0 0 load-list 2! false +; + +: load ( "{params}<eol>"} -- success ) \ Client interface to load + parse-word 0d parse -leading 2swap ?dup IF + de-alias + set-boot-device + ELSE + drop + THEN + set-boot-args s" parse-load " $bootdev $cat strdup evaluate +; + +: load-next ( -- success ) \ Continue after go failed + load-list 2@ ?dup IF s" parse-load " 2swap $cat strdup evaluate + ELSE drop false THEN +; + +\ \\\\\\\\\\\\\\\\\\\\\\\\\\ +\ load/go utilities +\ -> Should be in loaders.fs + +: noload false ; + +' no-go to go + +: (go-and-catch) ( -- ) + \ Recommended Practice: Forth Source Support (scripts starting with comment) + get-load-base c@ 5c = get-load-base 1+ c@ 20 = AND IF + load-size alloc-mem ( allocated-addr ) + ?dup 0= IF ." alloc-mem failed." cr EXIT THEN + load-size >r >r ( R: allocate-addr load-size ) + get-load-base r@ load-size move \ Move away from load-base + r@ load-size evaluate \ Run the script + r> r> free-mem + EXIT + THEN + \ Assume it's a normal executable, use "go" to run it: + ['] go behavior CATCH IF -69 boot-exception-handler THEN +; + + +\ if the board does not get the bootlist from the nvram +\ then this word is supposed to be overloaded with the +\ word to get the bootlist from VPD (or from wheresoever) +read-bootlist + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ IEEE 1275 : load (user interface) +\ * +: boot + load 0= IF -65 boot-exception-handler EXIT THEN + disable-watchdog (go-and-catch) + BEGIN load-next WHILE + disable-watchdog (go-and-catch) + REPEAT + + \ When we return from boot print the banner again. + .banner +; + +: load load 0= IF -65 boot-exception-handler THEN ; + +\ \\\\ Temporary hacks for backwards compatibility +: yaboot ." Use 'boot disk' instead " ; + +: netboot ( -- rc ) ." Use 'boot net' instead " ; + +: netboot-arg ( arg-string -- rc ) + s" boot net " 2swap $cat (parse-line) $cat + evaluate +; + +: netload ( -- rc ) (parse-line) + load-base-override >r flash-load-base to load-base-override + s" load net:" strdup 2swap $cat strdup evaluate + r> to load-base-override + load-size +; + +: neteval ( -- ) FLASH-LOAD-BASE netload evaluate ; + diff --git a/src/roms/SLOF/slof/fs/bootmsg.fs b/src/roms/SLOF/slof/fs/bootmsg.fs new file mode 100644 index 0000000..524d469 --- /dev/null +++ b/src/roms/SLOF/slof/fs/bootmsg.fs @@ -0,0 +1,74 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +create debugstr 255 allot +0 VALUE debuglen +\ tbl@ d# 1000 * 196e6aa / VALUE TIME1 +\ 0 VALUE TIME2 + +\ Usage: 42 cp +: cp ( checkpoint -- ) + \ cr depth 2 0.r s" : " type .s cr \ DEBUG + \ cr ." time: " tbl@ d# 1000 * 196e6aa / dup TIME1 - dup . cr TIME2 + TO TIME2 TO TIME1 + bootmsg-cp ; + +: (warning) ( id level ptr len -- ) + dup TO debuglen + debugstr swap move \ copy into buffer + 0 debuglen debugstr + c! \ terminate '\0' + debugstr bootmsg-warning +; + +\ Usage: 42 0 warning" warning-txt" +: warning" ( id level [text<">] -- ) + postpone s" state @ + IF + ['] (warning) compile, + ELSE + (warning) + THEN +; immediate + +: (debug-cp) ( id level ptr len -- ) + dup TO debuglen + debugstr swap move \ copy into buffer + 0 debuglen debugstr + c! \ terminate '\0' + debugstr bootmsg-debugcp +; + +\ Usage: 42 0 debug-cp" debug-cp-txt" +: debug-cp" ( id level [text<">] -- ) + postpone s" state @ + IF + ['] (debug-cp) compile, + ELSE + (debug-cp) + THEN +; immediate + +: (error) ( id ptr len -- ) + dup TO debuglen + debugstr swap move \ copy into buffer + 0 debuglen debugstr + c! \ terminate '\0' + debugstr bootmsg-error +; + +\ Usage: 42 error" error-txt" +: error" ( id level [text<">] -- ) + postpone s" state @ + IF + ['] (error) compile, + ELSE + (error) + THEN +; immediate + +bootmsg-nvupdate diff --git a/src/roms/SLOF/slof/fs/claim.fs b/src/roms/SLOF/slof/fs/claim.fs new file mode 100644 index 0000000..d012d3d --- /dev/null +++ b/src/roms/SLOF/slof/fs/claim.fs @@ -0,0 +1,415 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ \\\\\\\\\\\\\\ Constants +500 CONSTANT AVAILABLE-SIZE +4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages + +: MIN-RAM-SIZE \ Initially available memory size + epapr-ima-size IF + epapr-ima-size + ELSE + 20000000 \ assumed minimal memory size + THEN +; +MIN-RAM-SIZE CONSTANT MIN-RAM-SIZE + +\ \\\\\\\\\\\\\\ Structures +\ + +\ The available element size depends strictly on the address/size +\ value formats and will be different for various device types +\ + +STRUCT + cell field available>address + cell field available>size +CONSTANT /available + + +\ \\\\\\\\\\\\\\ Global Data +CREATE available AVAILABLE-SIZE /available * allot available AVAILABLE-SIZE /available * erase +VARIABLE mem-pre-released 0 mem-pre-released ! + +\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods +: available>size@ available>size @ ; +: available>address@ available>address @ ; +: available>size! available>size ! ; +: available>address! available>address ! ; + +: available! ( addr size available-ptr -- ) + dup -rot available>size! available>address! +; + +: available@ ( available-ptr -- addr size ) + dup available>address@ swap available>size@ +; + + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ + +\ Warning: They are not yet really independent from available formatting +\ + + +\ + +\ Find position in the "available" where given range exists or can be inserted, +\ return pointer and logical found/notfound value +\ If error, return NULL pointer in addition to notfound code +\ + +: (?available-segment<) ( start1 end1 start2 end2 -- true/false ) drop < nip ; + +: (?available-segment>) ( start1 end1 start2 end2 -- true/false ) -rot 2drop > ; + +\ start1 to end1 is the area that should be claimed +\ start2 to end2 is the available segment +\ return true if it can not be claimed, false if it can be claimed +: (?available-segment-#) ( start1 end1 start2 end2 -- true/false ) + 2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 ) + between >r between r> and not +; + +: (find-available) ( addr addr+size-1 a-ptr a-size -- a-ptr' found ) + ?dup 0= IF -rot 2drop false EXIT THEN \ Not Found + + 2dup 2/ dup >r /available * + + ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' ) + dup available>size@ 0= IF 2drop r> RECURSE EXIT THEN + + ( addr addr+size-1 a-ptr a-size a-ptr' R: a-size' ) + dup >r available@ + ( addr addr+size-1 a-ptr a-size addr' size' R: a-size' a-ptr' ) + over + 1- 2>r 2swap + ( a-ptr a-size addr addr+size-1 ) + ( R: a-size' a-ptr' addr' addr'+size'-1 ) + + 2dup 2r@ (?available-segment>) IF + 2swap 2r> 2drop r> + /available + -rot r> - 1- nip RECURSE EXIT \ Look Right + THEN + 2dup 2r@ (?available-segment<) IF + 2swap 2r> 2drop r> + 2drop r> RECURSE EXIT \ Look Left + THEN + 2dup 2r@ (?available-segment-#) IF \ Conflict - segments overlap + 2r> 2r> 3drop 3drop 2drop + 1212 throw + THEN + 2r> 3drop 3drop r> r> drop ( a-ptr' -- ) + dup available>size@ 0<> ( a-ptr' found -- ) +; + +: (find-available) ( addr size -- seg-ptr found ) + over + 1- available AVAILABLE-SIZE ['] (find-available) catch IF + 2drop 2drop 0 false + THEN +; + + +: dump-available ( available-ptr -- ) + cr + dup available - /available / AVAILABLE-SIZE swap - 0 ?DO + dup available@ ?dup 0= IF + 2drop UNLOOP EXIT + THEN + swap . . cr + /available + + LOOP + dup +; + +: .available available dump-available ; + +\ + +\ release utils: +\ + + +\ + +\ (drop-available) just blindly compresses space of available map +\ + +: (drop-available) ( available-ptr -- ) + dup available - /available / \ current element index + AVAILABLE-SIZE swap - \ # of remaining elements + + ( first nelements ) 1- 0 ?DO + dup /available + dup available@ + + ( current next next>address next>size ) ?dup 0= IF + 2drop LEAVE \ NULL element - goto last copy + THEN + 3 roll available! ( next ) + LOOP + + \ Last element : just zero it out + 0 0 rot available! +; + +\ + +\ (stick-to-previous-available) merge the segment on stack +\ with the previous one, if possible, and modified segment parameters if merged +\ Return success code +\ + +: (stick-to-previous-available) ( addr size available-ptr -- naddr nsize nptr success ) + dup available = IF + false EXIT \ This was the first available segment + THEN + + dup /available - dup available@ + + 4 pick = IF + nip \ Drop available-ptr since we are going to previous one + rot drop \ Drop start addr, we take the previous one + + dup available@ 3 roll + rot true + ( prev-addr prev-size+size prev-ptr true ) + ELSE + drop false + ( addr size available-ptr false ) + THEN +; + +\ + +\ (insert-available) just blindly makes space for another element on given +\ position +\ + +\ insert-available should also check adjacent elements and merge if new +\ region is contiguos w. others +\ + +: (insert-available) ( available-ptr -- available-ptr ) + dup \ current element + dup available - /available / \ current element index + AVAILABLE-SIZE swap - \ # of remaining elements + + dup 0<= 3 pick available>size@ 0= or IF + \ End of "available" or came to an empty element - Exit + drop drop EXIT + THEN + + over available@ rot + + ( first first/=current/ first>address first>size nelements ) 1- 0 ?DO + 2>r + ( first current R: current>address current>size ) + + /available + dup available@ + ( first current+1/=next/ next>address next>size ) + ( R: current>address current>size ) + + 2r> 4 pick available! dup 0= IF + \ NULL element - last copy + rot /available + available! + UNLOOP EXIT + THEN + LOOP + + ( first next/=last/ last[0]>address last[0]>size ) ?dup 0<> IF + cr ." release error: available map overflow" + cr ." Dumping available property" + .available + cr ." No space for one before last entry:" cr swap . . + cr ." Dying ..." cr 123 throw + THEN + + 2drop +; + +: insert-available ( addr size available-ptr -- addr size available-ptr ) + dup available>address@ 0<> IF + \ Not empty : + dup available>address@ rot dup -rot - + + ( addr available-ptr size available>address@-size ) + + 3 pick = IF \ if (available>address@ - size == addr) + \ Merge w. next segment - no insert needed + + over available>size@ + swap + ( addr size+available>size@ available-ptr ) + + (stick-to-previous-available) IF + \ Merged w. prev & next one : discard extra seg + dup /available + (drop-available) + THEN + ELSE + \ shift the rest of "available" to make space + + swap (stick-to-previous-available) + not IF (insert-available) THEN + THEN + ELSE + (stick-to-previous-available) drop + THEN +; + +defer release + +\ + +\ claim utils: +\ + +: drop-available ( addr size available-ptr -- addr ) + dup >r available@ + ( req_addr req_size segment_addr segment_size R: available-ptr ) + + over 4 pick swap - ?dup 0<> IF + \ Segment starts before requested address : free the head space + dup 3 roll swap r> available! - + + ( req_addr req_size segment_size-segment_addr+req_addr ) + over - ?dup 0= IF + \ That's it - remainder of segment is what we claim + drop + ELSE + \ Both head and tail of segment remain unclaimed : + \ need an extra available element + swap 2 pick + swap release + THEN + ELSE + nip ( req_addr req_size segment_size ) + over - ?dup 0= IF + \ Exact match : drop the whole available segment + drop r> (drop-available) + ELSE + \ We claimed the head, need to leave the tail available + -rot over + rot r> available! + THEN + THEN + ( base R: -- ) +; + +: pwr2roundup ( value -- pwr2value ) + dup CASE + 0 OF EXIT ENDOF + 1 OF EXIT ENDOF + ENDCASE + dup 1 DO drop i dup +LOOP + dup + +; + +: (claim-best-fit) ( len align -- len base ) + pwr2roundup 1- -1 -1 + ( len align-1 best-fit-residue/=-1/ best-fit-base/=-1/ ) + + available AVAILABLE-SIZE /available * + available DO + i \ Must be saved now, before we use Return stack + -rot >r >r swap >r + + ( len i R: best-fit-base best-fit-residue align-1 ) + + available@ ?dup 0= IF drop r> r> r> LEAVE THEN \ EOL + + 2 pick - dup 0< IF + 2drop \ Can't Fit: Too Small + ELSE + dup 2 pick r@ and - 0< IF + 2drop \ Can't Fit When Aligned + ELSE + ( len i>address i>size-len ) + ( R: best-fit-base best-fit-residue align-1 ) + r> -rot dup r@ U< IF + \ Best Fit so far: drop the old one + 2r> 2drop + + ( len align-1 nu-base nu-residue R: ) + \ Now align new base and push to R: + swap 2 pick + 2 pick invert and >r >r >r + ELSE + 2drop >r + THEN + THEN + THEN + r> r> r> + /available +LOOP + + -rot 2drop ( len best-fit-base/or -1 if none found/ ) +; + +: (adjust-release0) ( 0 size -- addr' size' ) + \ segment 0 already pre-relased in early phase: adjust + 2dup MIN-RAM-SIZE dup 3 roll + -rot - + dup 0< IF 2drop ELSE + 2swap 2drop 0 mem-pre-released ! + THEN +; + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ + +\ IEEE 1275 implementation: +\ claim +\ Claim the region with given start address and size (if align parameter is 0); +\ alternatively claim any region of given alignment +\ + +\ Throw an exception if failed +\ + +: claim ( [ addr ] len align -- base ) + ?dup 0<> IF + (claim-best-fit) dup -1 = IF + 2drop cr ." claim error : aligned allocation failed" cr + ." available:" cr .available + 321 throw EXIT + THEN + swap + THEN + + 2dup (find-available) not IF + drop +\ cr ." claim error : requested " . ." bytes of memory at " . +\ ." not available" cr +\ ." available:" cr .available + 2drop + 321 throw EXIT + THEN + ( req_addr req_size available-ptr ) drop-available + + ( req_addr ) +; + + +\ + +\ IEEE 1275 implementation: +\ release +\ Free the region with given start address and size +\ + +: .release ( addr len -- ) + over 0= mem-pre-released @ and IF (adjust-release0) THEN + + 2dup (find-available) IF + drop swap + cr ." release error: region " . ." , " . ." already released" cr + ELSE + ?dup 0= IF + swap + cr ." release error: Bad/conflicting region " . ." , " . + ." or available list full " cr + ELSE + ( addr size available-ptr ) insert-available + + \ NOTE: insert did not change the stack layout + \ but it may have changed any of the three values + \ in order to implement merge of free regions + \ We do not interpret these values any more + \ just blindly copy it in + + ( addr size available-ptr ) available! + THEN + THEN +; + +' .release to release + + +\ pre-release minimal memory size +0 MIN-RAM-SIZE release 1 mem-pre-released ! + +\ claim first pages used for PPC exception vectors +0 MIN-RAM-RESERVE 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop + +\ claim region used by firmware (assume 31 MiB size right now) +paflof-start ffff not and 1f00000 0 ' claim CATCH IF + ." claim failed!" cr 2drop +THEN drop diff --git a/src/roms/SLOF/slof/fs/client.fs b/src/roms/SLOF/slof/fs/client.fs new file mode 100644 index 0000000..7d537a6 --- /dev/null +++ b/src/roms/SLOF/slof/fs/client.fs @@ -0,0 +1,311 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Client interface. + +0 VALUE debug-client-interface? + +\ First, the machinery. + +VOCABULARY client-voc \ We store all client-interface callable words here. + +6789 CONSTANT sc-exit +4711 CONSTANT sc-yield + +VARIABLE client-callback \ Address of client's callback function + +: client-data ciregs >r3 @ ; +: nargs client-data la1+ l@ ; +: nrets client-data la1+ la1+ l@ ; +: client-data-to-stack + client-data 3 la+ nargs 0 ?DO dup l@ swap la1+ LOOP drop ; +: stack-to-client-data + client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ; + +: call-client ( args len client-entry -- ) + \ (args, len) describe the argument string, client-entry is the address of + \ the client's .entry symbol, i.e. where we eventually branch to. + \ ciregs is a variable that describes the register set of the host processor, + \ see slof/fs/exception.fs for details + \ client-entry-point maps to client_entry_point in slof/entry.S which is + \ the SLOF entry point when calling a SLOF client interface word from the + \ client. + \ We pass the arguments for the client in R6 and R7, the client interface + \ entry point address is passed in R5. + >r ciregs >r7 ! ciregs >r6 ! client-entry-point @ ciregs >r5 ! + \ Initialise client-stack-pointer + cistack ciregs >r1 ! + \ jump-client maps to call_client in slof/entry.S + \ When jump-client returns, R3 holds the address of a NUL-terminated string + \ that holds the client interface word the client wants to call, R4 holds + \ the return address. + r> jump-client drop + BEGIN + client-data-to-stack + \ Now create a Forth-style string, look it up in the client dictionary and + \ execute it, guarded by CATCH. Result of xt == 0 is stored on the return + \ stack + client-data l@ zcount + \ XXX: Should only look in client-voc... + ALSO client-voc $find PREVIOUS + dup 0= >r IF + CATCH + \ If a client interface word needs some special treatment, like exit and + \ yield, then the implementation needs to use THROW to indicate its needs + ?dup IF + dup CASE + sc-exit OF drop r> drop EXIT ENDOF + sc-yield OF drop r> drop EXIT ENDOF + ENDCASE + \ Some special call was made but we don't know that to do with it... + THROW + THEN + stack-to-client-data + ELSE + cr type ." NOT FOUND" + THEN + \ Return to the client + r> ciregs >r3 ! ciregs >r4 @ jump-client + UNTIL ; + +: flip-stack ( a1 ... an n -- an ... a1 ) ?dup IF 1 ?DO i roll LOOP THEN ; + +: (callback) ( "service-name<>" "arguments<cr>" -- ) + client-callback @ \ client-callback points to the function prolog + dup 8 + @ ciregs >r2 ! \ Set up the TOC pointer (???) + @ call-client ; \ Resolve the function's address from the prolog +' (callback) to callback + +: (continue-client) + s" " \ make call-client happy, client won't use the string anyways. + ciregs >r4 @ call-client ; +' (continue-client) to continue-client + +\ Utility. +: string-to-buffer ( str len buf len -- len' ) + 2dup erase rot min dup >r move r> ; + +\ Now come the actual client interface words. + +ALSO client-voc DEFINITIONS + +: exit sc-exit THROW ; + +: yield sc-yield THROW ; + +: test ( zstr -- missing? ) + \ XXX: Should only look in client-voc... + zcount + debug-client-interface? IF + ." ci: test " 2dup type cr + THEN + ALSO client-voc $find PREVIOUS IF + drop FALSE + ELSE + 2drop TRUE + THEN +; + +: finddevice ( zstr -- phandle ) + zcount + debug-client-interface? IF + ." ci: finddevice " 2dup type cr + THEN + 2dup " /memory" str= IF + \ Workaround: grub passes /memory instead of /memory@0 + 2drop + " /memory@0" + THEN + find-node dup 0= IF drop -1 THEN +; + +: getprop ( phandle zstr buf len -- len' ) + >r >r zcount rot ( str-adr str-len phandle R: len buf ) + debug-client-interface? IF + ." ci: getprop " 3dup . ." '" type ." '" + THEN + get-property + debug-client-interface? IF + dup IF ." ** not found **" THEN + cr + THEN + 0= IF + r> swap dup r> min swap >r move r> + ELSE + r> r> 2drop -1 + THEN +; + +: getproplen ( phandle zstr -- len ) + zcount rot get-property 0= IF nip ELSE -1 THEN ; + +: setprop ( phandle zstr buf len -- size|-1 ) + dup >r \ save len + encode-bytes ( phandle zstr prop-addr prop-len ) + 2swap zcount rot ( prop-addr prop-len name-addr name-len phandle ) + current-node @ >r \ save current node + set-node \ change to specified node + property \ set property + r> set-node \ restore original node + r> \ always return size, because we can not fail. +; + +\ VERY HACKISH +: canon ( zstr buf len -- len' ) + 2dup erase + >r >r zcount + >r dup c@ [char] / = IF + r> r> swap r> over >r min move r> + ELSE + r> find-alias ?dup 0= IF + r> r> 2drop -1 + ELSE + dup -rot r> swap r> min move + THEN + THEN +; + +: nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok + >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ; + +: open ( zstr -- ihandle ) + zcount + debug-client-interface? IF + ." ci: open " 2dup type cr + THEN + open-dev +; + +: close ( ihandle -- ) + debug-client-interface? IF + ." ci: close " dup . cr + THEN + s" stdin" get-chosen IF + decode-int nip nip over = IF + \ End of life of SLOF now, call platform quiesce as quiesce + \ is an undocumented extension and not everybody supports it + close-dev + quiesce + ELSE + close-dev + THEN + ELSE + close-dev + THEN +; + +\ Now implemented: should return -1 if no such method exists in that node +: write ( ihandle str len -- len' ) rot s" write" rot + ['] $call-method CATCH IF 2drop 3drop -1 THEN ; +: read ( ihandle str len -- len' ) rot s" read" rot + ['] $call-method CATCH IF 2drop 3drop -1 THEN ; +: seek ( ihandle hi lo -- status ) swap rot s" seek" rot + ['] $call-method CATCH IF 2drop 3drop -1 THEN ; + +\ A real claim implementation: 3.2% memory fat :-) +: claim ( addr len align -- base ) + debug-client-interface? IF + ." ci: claim " .s cr + THEN + dup IF rot drop + ['] claim CATCH IF 2drop -1 THEN + ELSE + ['] claim CATCH IF 3drop -1 THEN + THEN +; + +: release ( addr len -- ) + debug-client-interface? IF + ." ci: release " .s cr + THEN + release +; + +: instance-to-package ( ihandle -- phandle ) + ihandle>phandle ; + +: package-to-path ( phandle buf len -- len' ) + 2>r node>path 2r> string-to-buffer ; +: instance-to-path ( ihandle buf len -- len' ) + 2>r instance>path 2r> string-to-buffer ; +: instance-to-interposed-path ( ihandle buf len -- len' ) + 2>r instance>qpath 2r> string-to-buffer ; + +: call-method ( str ihandle arg ... arg -- result return ... return ) + nargs flip-stack zcount + debug-client-interface? IF + ." ci: call-method " 2dup type cr + THEN + rot ['] $call-method CATCH + nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result + dup IF nrets 1 ?DO -444 LOOP THEN + nrets flip-stack + THEN +; + +\ From the PAPR. +: test-method ( phandle str -- missing? ) + zcount + debug-client-interface? IF + ." ci: test-method " 2dup type cr + THEN + rot find-method dup IF nip THEN 0= +; + +: milliseconds milliseconds ; + +: start-cpu ( phandle addr r3 -- ) + >r >r + s" reg" rot get-property 0= IF drop l@ + ELSE true ABORT" start-cpu called with invalid phandle" THEN + r> r> of-start-cpu drop +; + +\ Quiesce firmware and assert that all hardware is in a sane state +\ (e.g. assert that no background DMA is running anymore) +: quiesce ( -- ) + debug-client-interface? IF + ." ci: quiesce" cr + THEN + \ The main quiesce call is defined in quiesce.fs + quiesce +; + +\ +\ Standard for Boot, defined in 6.3.2.5: +\ +: boot ( zstr -- ) + zcount + debug-client-interface? IF + ." ci: boot " 2dup type cr + THEN + " boot " 2swap $cat " boot-command" $setenv (nvupdate) + reset-all +; + +\ +\ User Interface, defined in 6.3.2.6 +\ +: interpret ( ... zstr -- result ... ) + zcount + debug-client-interface? IF + ." ci: interpret " 2dup type cr + THEN + ['] evaluate CATCH +; + +\ Allow the client to register a callback +: set-callback ( newfunc -- oldfunc ) + client-callback @ swap client-callback ! ; + +PREVIOUS DEFINITIONS diff --git a/src/roms/SLOF/slof/fs/debug.fs b/src/roms/SLOF/slof/fs/debug.fs new file mode 100644 index 0000000..e54f729 --- /dev/null +++ b/src/roms/SLOF/slof/fs/debug.fs @@ -0,0 +1,422 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Get the name of Forth command whose execution token is xt + +: xt>name ( xt -- str len ) + BEGIN + cell - dup c@ 0 2 within IF + dup 2+ swap 1+ c@ exit + THEN + AGAIN +; + +cell -1 * CONSTANT -cell +: cell- ( n -- n-cell-size ) + [ cell -1 * ] LITERAL + +; + +\ Search for xt of given address +: find-xt-addr ( addr -- xt ) + BEGIN + dup @ <colon> = IF + EXIT + THEN + cell- + AGAIN +; + +: (.immediate) ( xt -- ) + \ is it immediate? + xt>name drop 2 - c@ \ skip len and flags + immediate? IF + ." IMMEDIATE" + THEN +; + +: (.xt) ( xt -- ) + xt>name type +; + +\ Trace back on current return stack. +\ Start at 1, since 0 is return of trace-back itself + +: trace-back ( ) + 1 + BEGIN + cr dup dup . ." : " rpick dup . ." : " + ['] tib here within IF + dup rpick find-xt-addr (.xt) + THEN + 1+ dup rdepth 5 - >= IF cr drop EXIT THEN + AGAIN +; + +VARIABLE see-my-type-column + +: (see-my-type) ( indent limit xt str len -- indent limit xt ) + dup see-my-type-column @ + dup 50 >= IF + -rot over " " comp 0= IF + \ blank causes overflow: just enforce new line with next call + 2drop see-my-type-column ! + ELSE + rot drop ( indent limit xt str len ) + \ Need to copy string since we use (u.) again (kills internal buffer): + pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk ) + move r> r> ( indent limit xt pk len ) + 2 pick (u.) dup -rot + cr type ( indent limit xt pk len xt-len ) + " :" type 1+ ( indent limit xt pk len prefix-len ) + 5 pick dup spaces + ( indent limit xt pk len prefix-len ) + over + see-my-type-column ! ( indent limit xt pk len ) + type + THEN ( indent limit xt ) + ELSE + see-my-type-column ! type ( indent limit xt ) + THEN +; + +: (see-my-type-init) ( -- ) + ffff see-my-type-column ! \ just enforce a new line +; + +: (see-colon-body) ( indent limit xt -- indent limit xt ) + (see-my-type-init) \ enforce new line + BEGIN ( indent limit xt ) + cell+ 2dup <> + over @ + dup <semicolon> <> + rot and ( indent limit xt @xt flag ) + WHILE ( indent limit xt @xt ) + xt>name (see-my-type) " " (see-my-type) + dup @ ( indent limit xt @xt) + CASE + <0branch> OF cell+ dup @ + over + cell+ dup >r + (u.) (see-my-type) r> ( indent limit xt target) + 2dup < IF + over 4 pick 3 + -rot recurse + nip nip nip cell- ( indent limit xt ) + ELSE + drop ( indent limit xt ) + THEN + (see-my-type-init) ENDOF \ enforce new line + <branch> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <do?do> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <lit> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <dotick> OF cell+ dup @ xt>name (see-my-type) + " " (see-my-type) ENDOF + <doloop> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <do+loop> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <doleave> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <do?leave> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <sliteral> OF cell+ " """ (see-my-type) dup count dup >r + (see-my-type) " """ (see-my-type) + " " (see-my-type) + r> -cell and + ENDOF + ENDCASE + REPEAT + drop +; + +: (see-colon) ( xt -- ) + (see-my-type-init) + 1 swap 0 swap ( indent limit xt ) + " : " (see-my-type) dup xt>name (see-my-type) + rot drop 4 -rot (see-colon-body) ( indent limit xt ) + rot drop 1 -rot (see-my-type-init) " ;" (see-my-type) + 3drop +; + +\ Create words are a bit tricky. We find out where their code points. +\ If this code is part of SLOF, it is not a user generated CREATE. + +: (see-create) ( xt -- ) + dup cell+ @ + CASE + <2constant> OF + dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT " + ENDOF + + <instancevalue> OF + dup cell+ cell+ @ . ." INSTANCE VALUE " + ENDOF + + <instancevariable> OF + ." INSTANCE VARIABLE " + ENDOF + + dup OF + ." CREATE " + ENDOF + ENDCASE + (.xt) +; + +\ Decompile Forth command whose execution token is xt + +: (see) ( xt -- ) + cr dup dup @ + CASE + <variable> OF ." VARIABLE " (.xt) ENDOF + <value> OF dup execute . ." VALUE " (.xt) ENDOF + <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF + <defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF + <alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF + <buffer:> OF ." BUFFER: " (.xt) ENDOF + <create> OF (see-create) ENDOF + <colon> OF (see-colon) ENDOF + dup OF ." ??? PRIM " (.xt) ENDOF + ENDCASE + (.immediate) cr + ; + +\ Decompile Forth command old-name + +: see ( "old-name<>" -- ) + ' (see) +; + +\ Work in progress... + +0 value forth-ip +true value trace>stepping? +true value trace>print? +true value trace>up? +0 value trace>depth +0 value trace>rdepth +0 value trace>recurse +: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ; +: trace-depth- ( -- ) trace>depth 1- to trace>depth ; + +: stepping ( -- ) + true to trace>stepping? +; + +: tracing ( -- ) + false to trace>stepping? +; + +: trace-print-on ( -- ) + true to trace>print? +; + +: trace-print-off ( -- ) + false to trace>print? +; + + +\ Add n to ip + +: fip-add ( n -- ) + forth-ip + to forth-ip +; + +\ Save execution token address and content + +0 value debug-last-xt +0 value debug-last-xt-content + +: trace-print ( -- ) + forth-ip cr u. ." : " + forth-ip @ + dup ['] breakpoint = IF drop debug-last-xt-content THEN + xt>name type ." " + ." ( " .s ." ) | " +; + +: trace-interpret ( -- ) + rdepth 1- to trace>rdepth + BEGIN + depth . [char] > dup emit emit space + source expect ( str len ) + ['] interpret catch print-status + AGAIN +; + +\ Main trace routine, trace a colon definition + +: trace-xt ( xt -- ) + trace>recurse IF + r> drop \ Drop return of 'trace-xt call + cell+ \ Step over ":" + ELSE + debug-last-xt-content <colon> = IF + \ debug colon-definition + ['] breakpoint @ debug-last-xt ! \ Re-arm break point + r> drop \ Drop return of 'trace-xt call + cell+ \ Step over ":" + ELSE + ['] breakpoint debug-last-xt ! \ Re-arm break point + 2r> 2drop + THEN + THEN + + to forth-ip + true to trace>print? + BEGIN + trace>print? IF trace-print THEN + + forth-ip ( ip ) + trace>stepping? IF + BEGIN + key + CASE + [char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions + trace-depth+ + 1 to trace>recurse + dup >r @ recurse + THEN true ENDOF + [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF + [char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack + [char] c OF tracing true ENDOF + [char] t OF trace-back false ENDOF + [char] q OF drop cr quit ENDOF + 20 OF true ENDOF + dup OF cr ." Press d: Down into current word" cr + ." Press u: Up to caller" cr + ." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr + ." Press c: Switch to tracing" cr + ." Press <space>: Execute current word" cr + ." Press q: Abort execution, switch to interpreter" cr + false ENDOF + ENDCASE + UNTIL + THEN ( ip' ) + dup to forth-ip @ ( xt ) + dup ['] breakpoint = IF drop debug-last-xt-content THEN + dup ( xt xt ) + + CASE + <sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF + <dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF + <lit> OF drop forth-ip cell+ @ cell fip-add ENDOF + <doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF + <(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF + <0branch> OF drop IF + cell fip-add + ELSE + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + <do?do> OF drop 2dup <> IF + swap >r >r cell fip-add + ELSE + forth-ip cell+ @ cell+ fip-add 2drop THEN + ENDOF + <branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF + <doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF + <do?leave> OF drop IF + r> r> 2drop forth-ip cell+ @ cell+ fip-add + ELSE + cell fip-add + THEN + ENDOF + <doloop> OF drop r> 1+ r> 2dup = IF + 2drop cell fip-add + ELSE >r >r + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + <do+loop> OF drop r> + r> 2dup >= IF + 2drop cell fip-add + ELSE >r >r + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + + <semicolon> OF trace>depth 0> IF + trace-depth- 1 to trace>recurse + stepping drop r> recurse + ELSE + drop exit THEN + ENDOF + <exit> OF trace>depth 0> IF + trace-depth- stepping drop r> recurse + ELSE + drop exit THEN + ENDOF + dup OF execute ENDOF + ENDCASE + forth-ip cell+ to forth-ip + AGAIN +; + +\ Resume execution from tracer +: resume ( -- ) + trace>rdepth rdepth! + forth-ip cell - trace-xt +; + +\ Turn debug off, by erasing breakpoint + +: debug-off ( -- ) + debug-last-xt IF + debug-last-xt-content debug-last-xt ! \ Restore overwritten token + 0 to debug-last-xt + THEN +; + + + +\ Entry point for debug + +: (break-entry) ( -- ) + debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt ) + debug-last-xt-content swap ! \ Restore overwritten token + r> drop \ Don't return to bp, but to caller + debug-last-xt-content <colon> <> and IF \ Execute non colon definition + debug-last-xt cr u. ." : " + debug-last-xt xt>name type ." " + ." ( " .s ." ) | " + key drop + debug-last-xt execute + ELSE + debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition + THEN +; + +\ Put entry point bp defer +' (break-entry) to BP + +\ Mark an address for debugging + +: debug-address ( addr -- ) + debug-off ( xt ) \ Remove active breakpoint + dup to debug-last-xt ( xt ) \ Save token for later debug + dup @ to debug-last-xt-content ( xt ) \ Save old value + ['] breakpoint swap ! +; + +\ Mark the command indicated by xt for debugging + +: (debug ( xt -- ) + debug-off ( xt ) \ Remove active breakpoint + dup to debug-last-xt ( xt ) \ Save token for later debug + dup @ to debug-last-xt-content ( xt ) \ Save old value + ['] breakpoint @ swap ! +; + +\ Mark the command indicated by xt for debugging + +: debug ( "old-name<>" -- ) + parse-word $find IF \ Get xt for old-name + (debug + ELSE + ." undefined word " type cr + THEN +; diff --git a/src/roms/SLOF/slof/fs/devices/pci-class_02.fs b/src/roms/SLOF/slof/fs/devices/pci-class_02.fs new file mode 100644 index 0000000..271420f --- /dev/null +++ b/src/roms/SLOF/slof/fs/devices/pci-class_02.fs @@ -0,0 +1,37 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +s" network [ " type my-space pci-class-name type s" ]" type + +my-space pci-device-generic-setup +my-space pci-alias-net + +s" network" device-type + +cr + +INSTANCE VARIABLE obp-tftp-package +: open ( -- okay? ) + open IF \ enables PCI mem, io and Bus master and returns TRUE + my-args s" obp-tftp" $open-package obp-tftp-package ! true + ELSE + false + THEN ; + +: close ( -- ) + obp-tftp-package @ close-package + close ; \ disables PCI mem, io and Bus master + +: load ( addr -- len ) + s" load" obp-tftp-package @ $call-method ; + +: ping ( -- ) s" ping" obp-tftp-package @ $call-method ; diff --git a/src/roms/SLOF/slof/fs/devices/pci-class_0c.fs b/src/roms/SLOF/slof/fs/devices/pci-class_0c.fs new file mode 100644 index 0000000..39453fb --- /dev/null +++ b/src/roms/SLOF/slof/fs/devices/pci-class_0c.fs @@ -0,0 +1,71 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +s" serial bus [ " type my-space pci-class-name type s" ]" type cr + +my-space pci-device-generic-setup + +STRUCT + /n FIELD hcd>base + /n FIELD hcd>type + /n FIELD hcd>num + /n FIELD hcd>ops + /n FIELD hcd>priv + /n FIELD hcd>nextaddr +CONSTANT /hci-dev + +: usb-setup-hcidev ( num hci-dev -- ) + >r + 10 config-l@ F AND case + 0 OF 10 config-l@ translate-my-address ENDOF \ 32-bit memory space + 4 OF \ 64-bit memory space + 14 config-l@ 20 lshift \ Read two bars + 10 config-l@ OR translate-my-address + ENDOF + ENDCASE + F not AND + ( io-base ) r@ hcd>base ! + 08 config-l@ 8 rshift 0000000F0 AND 4 rshift + ( usb-type ) r@ hcd>type ! + ( usb-num ) r@ hcd>num ! + r> drop +; + +\ Handle USB OHCI controllers: +: handle-usb-class ( -- ) + \ set Memory Write and Invalidate Enable, SERR# Enable + \ (see PCI 3.0 Spec Chapter 6.2.2 device control): + 4 config-w@ 110 or 4 config-w! + pci-master-enable \ set PCI Bus master bit and + pci-mem-enable \ memory space enable for USB scan +; + +\ Check PCI sub-class and interface type of Serial Bus Controller +\ to include the appropriate driver: +: handle-sbc-subclass ( -- ) + my-space pci-class@ ffff and CASE \ get PCI sub-class and interface + 0310 OF \ OHCI controller + handle-usb-class + set-ohci-alias + ENDOF + 0320 OF \ EHCI controller + handle-usb-class + set-ehci-alias + ENDOF + 0330 OF \ XHCI controller + handle-usb-class + set-xhci-alias + ENDOF + ENDCASE +; + +handle-sbc-subclass diff --git a/src/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs b/src/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs new file mode 100644 index 0000000..bb3b835 --- /dev/null +++ b/src/roms/SLOF/slof/fs/devices/pci-device_10de_0141.fs @@ -0,0 +1,49 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +my-space pci-class-name type + +my-space pci-device-generic-setup + +pci-io-enable +pci-mem-enable + +30 config-l@ pci-find-fcode execute-rom-fcode + +: check-display ( nodepath len -- true|false ) \ true if display found and "screen" alias set +\ check if display available, set screen alias +2dup find-node \ ( path len phandle|0 ) find node +?dup IF + \ node found, get "display-type" property + s" display-type" rot get-property ( path len true|propaddr proplen 0 ) + 0= IF + ( path len propaddr proplen ) \ property found, check if the value is not "NONE" + s" NONE" 0 char-cat ( path len propaddr proplen str strlen ) \ null-terminated NONE string + str= 0= IF + ( path len ) \ "display-type" property is not "NONE" so we can set "screen" alias + s" screen" 2swap set-alias + true ( true ) \ return true + ELSE + 2drop false ( false ) \ return false + THEN + THEN +THEN +; + +get-node node>path s" /NVDA,DISPLAY-A" $cat check-display +0= IF + \ no display found on DISPLAY-A ... check DISPLAY-B + get-node node>path s" /NVDA,DISPLAY-B" $cat check-display + drop \ drop result +THEN + +s" name" get-my-property drop s" ( " type type s" ) " type cr diff --git a/src/roms/SLOF/slof/fs/dictionary.fs b/src/roms/SLOF/slof/fs/dictionary.fs new file mode 100644 index 0000000..3e5b293 --- /dev/null +++ b/src/roms/SLOF/slof/fs/dictionary.fs @@ -0,0 +1,74 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: words + last @ + BEGIN ?dup WHILE + dup cell+ char+ count type space @ + REPEAT +; + +: .calls ( xt -- ) + current-node @ >r 0 set-node \ only search commands, according too IEEE1275 + + last BEGIN @ ?dup WHILE ( xt currxt ) + dup cell+ char+ ( xt currxt name* ) + dup dup c@ + 1+ aligned ( xt currxt name* CFA ) + dup @ <colon> = IF ( xt currxt name* CFA ) + BEGIN + cell+ dup @ ['] semicolon <> + WHILE ( xt currxt *name pos ) + dup @ 4 pick = IF ( xt currxt *name pos ) + over count type space + BEGIN cell+ dup @ ['] semicolon = UNTIL cell - \ eat up other occurrences + THEN + REPEAT + THEN + 2drop ( xt currxt ) + REPEAT + drop + + r> set-node \ restore node +; + +0 value #sift-count +false value sift-compl-only + +: $inner-sift ( text-addr text-len LFA -- ... word-addr word-len true | false ) + dup cell+ char+ count \ get word name + 2dup 6 pick 6 pick find-isubstr \ is there a partly match? + \ in tab completion mode the substring has to be at the beginning + sift-compl-only IF 0= ELSE over < THEN + IF + #sift-count 1+ to #sift-count \ count completions + true + ELSE + 2drop false + THEN +; + +: $sift ( text-addr text-len -- ) + current-node @ >r 0 set-node \ only search commands, according too IEEE1275 + sift-compl-only >r false to sift-compl-only \ all substrings, not only compl. + last BEGIN @ ?dup WHILE \ walk the whole dictionary + $inner-sift IF type space THEN + REPEAT + 2drop + 0 to #sift-count \ we don't need completions here. + r> to sift-compl-only \ restore previous sifting mode + r> set-node \ restore node +; + +: sifting ( "text< >" -- ) + parse-word $sift +; + diff --git a/src/roms/SLOF/slof/fs/display.fs b/src/roms/SLOF/slof/fs/display.fs new file mode 100644 index 0000000..5bb8797 --- /dev/null +++ b/src/roms/SLOF/slof/fs/display.fs @@ -0,0 +1,123 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +0 VALUE char-height +0 VALUE char-width +0 VALUE fontbytes + +CREATE display-emit-buffer 20 allot + +\ \\\\\\\\\\\\\\ Global Data + +\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ * +\ * +defer dis-old-emit +' emit behavior to dis-old-emit + +: display-write terminal-write ; +: display-emit dup dis-old-emit display-emit-buffer tuck c! 1 terminal-write drop ; + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ Generic device methods: +\ * + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ IEEE 1275 : display device driver initialization +\ * +: is-install ( 'open -- ) + s" defer vendor-open to vendor-open" eval + s" : open deadbeef vendor-open dup deadbeef = IF drop true ELSE nip THEN ;" eval + s" defer write ' display-write to write" eval + s" : draw-logo ['] draw-logo CATCH IF 2drop 2drop THEN ;" eval + s" : reset-screen ['] reset-screen CATCH drop ;" eval +; + +: is-remove ( 'close -- ) + s" defer close to close" eval +; + +: is-selftest ( 'selftest -- ) + s" defer selftest to selftest" eval +; + + +STRUCT + cell FIELD font>addr + cell FIELD font>width + cell FIELD font>height + cell FIELD font>advance + cell FIELD font>min-char + cell FIELD font>#glyphs +CONSTANT /font + +CREATE default-font-ctrblk /font allot default-font-ctrblk + dup font>addr 0 swap ! + dup font>width 8 swap ! + dup font>height -10 swap ! + dup font>advance 1 swap ! + dup font>min-char 20 swap ! + font>#glyphs 7f swap ! + +: display-default-font ( str len -- ) + romfs-lookup dup 0= IF drop EXIT THEN + 600 <> IF ." Only support 60x8x16 fonts ! " drop EXIT THEN + default-font-ctrblk font>addr ! +; + +s" default-font.bin" display-default-font + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ * +\ * + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ Generic device methods: +\ * +: .scan-lines ( height -- scanlines ) dup 0>= IF 1- ELSE negate THEN ; + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ * + +: set-font ( addr width height advance min-char #glyphs -- ) + default-font-ctrblk /font + /font 0 + DO + 1 cells - dup >r ! r> 1 cells + +LOOP drop + default-font-ctrblk dup font>height @ abs to char-height + dup font>width @ to char-width font>advance @ to fontbytes +; + +: >font ( char -- addr ) + dup default-font-ctrblk dup >r font>min-char @ dup r@ font>#glyphs + within + IF + r@ font>min-char @ - + r@ font>advance @ * r@ font>height @ .scan-lines * + r> font>addr @ + + ELSE + drop r> font>addr @ + THEN +; + +: default-font ( -- addr width height advance min-char #glyphs ) + default-font-ctrblk /font 0 DO dup cell+ >r @ r> 1 cells +LOOP drop +; + diff --git a/src/roms/SLOF/slof/fs/dma-function.fs b/src/roms/SLOF/slof/fs/dma-function.fs new file mode 100644 index 0000000..c1c8716 --- /dev/null +++ b/src/roms/SLOF/slof/fs/dma-function.fs @@ -0,0 +1,36 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2014 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ DMA memory allocation functions +: dma-alloc ( size -- virt ) + my-phandle TO calling-child + s" dma-alloc" my-phandle parent $call-static + 0 TO calling-child +; + +: dma-free ( virt size -- ) + my-phandle TO calling-child + s" dma-free" my-phandle parent $call-static + 0 TO calling-child +; + +: dma-map-in ( virt size cacheable? -- devaddr ) + my-phandle TO calling-child + s" dma-map-in" my-phandle parent $call-static + 0 TO calling-child +; + +: dma-map-out ( virt devaddr size -- ) + my-phandle TO calling-child + s" dma-map-out" my-phandle parent $call-static + 0 TO calling-child +; diff --git a/src/roms/SLOF/slof/fs/dump.fs b/src/roms/SLOF/slof/fs/dump.fs new file mode 100644 index 0000000..90d60c4 --- /dev/null +++ b/src/roms/SLOF/slof/fs/dump.fs @@ -0,0 +1,42 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Hex dump facilities. + +1 VALUE /dump +' c@ VALUE 'dump +0 VALUE dump-first +0 VALUE dump-last +0 VALUE dump-cur +: .char ( c -- ) dup bl 7f within 0= IF drop [char] . THEN emit ; +: dump-line ( -- ) + cr dump-cur dup 8 0.r [char] : emit 10 /dump / 0 DO + space dump-cur dump-first dump-last within IF + dump-cur 'dump execute /dump 2* 0.r ELSE + /dump 2* spaces THEN dump-cur /dump + to dump-cur LOOP + /dump 1 <> IF drop EXIT THEN + to dump-cur 2 spaces + 10 0 DO dump-cur dump-first dump-last within IF + dump-cur 'dump execute .char ELSE space THEN dump-cur 1+ to dump-cur LOOP ; +: (dump) ( addr len reader size -- ) + to /dump to 'dump bounds /dump negate and to dump-first to dump-last + dump-first f invert and to dump-cur + base @ hex BEGIN dump-line dump-cur dump-last >= UNTIL base ! ; +: du ( -- ) dump-last 100 'dump /dump (dump) ; +: dump ['] c@ 1 (dump) ; +: wdump ['] w@ 2 (dump) ; +: ldump ['] l@ 4 (dump) ; +: xdump ['] x@ 8 (dump) ; +: rdump ['] rb@ 1 (dump) ; +\ : iodump ['] io-c@ 1 (dump) ; +\ : siodump ['] siocfg@ 1 (dump) ; diff --git a/src/roms/SLOF/slof/fs/elf.fs b/src/roms/SLOF/slof/fs/elf.fs new file mode 100644 index 0000000..5a80c78 --- /dev/null +++ b/src/roms/SLOF/slof/fs/elf.fs @@ -0,0 +1,71 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Claim memory for segment +\ Abort, if no memory available + +false value elf-claim? +0 value last-claim + +\ cur-brk is set by elf loader to end of data segment +0 VALUE cur-brk + + +: elf-claim-segment ( addr size -- errorcode ) + 2dup + elf-claim? IF + >r + here last-claim , to last-claim \ Setup ptr to last claim + \ Put addr and size in the data space + dup , r> dup , ( addr size ) + 0 ['] claim CATCH IF + ." Memory for ELF file is already in use!" cr + true ABORT" Memory for ELF file already in use " + THEN + drop + ELSE + 2drop + THEN + + to cur-brk + 0 +; + + +\ Load ELF file and claim the corresponding memory regions. +\ A destination address can be specified. If the parameter is -1 then +\ the file is loaded to the ddress that is specified in its header. +: elf-load-claim ( file-addr destaddr -- claim-list entry imagetype ) + true to elf-claim? + 0 to last-claim + dup -1 = IF \ If destaddr == -1 then load to addr from ELF header + drop ['] elf-load-file CATCH IF false to elf-claim? ABORT THEN + ELSE + ['] elf-load-file-to-addr CATCH IF false to elf-claim? ABORT THEN + THEN + >r + last-claim swap + false to elf-claim? + r> +; + + +\ Release memory claimed before + +: elf-release ( claim-list -- ) + BEGIN + dup cell+ ( claim-list claim-list-addr ) + dup @ swap cell+ @ ( claim-list claim-list-addr claim-list-sz ) + release ( claim-list ) + @ dup 0= ( Next-element ) + UNTIL + drop +; diff --git a/src/roms/SLOF/slof/fs/envvar.fs b/src/roms/SLOF/slof/fs/envvar.fs new file mode 100644 index 0000000..3364313 --- /dev/null +++ b/src/roms/SLOF/slof/fs/envvar.fs @@ -0,0 +1,412 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2012 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ configuration variables + +wordlist CONSTANT envvars + +\ list the names in envvars +: listenv ( -- ) + get-current envvars set-current words set-current +; + +\ create a definition in envvars +: create-env ( "name" -- ) + get-current envvars set-current CREATE set-current +; + +\ lay out the data for the separate envvar types +: env-int ( n -- ) 1 c, align , DOES> char+ aligned @ ; +: env-bytes ( a len -- ) + 2 c, align dup , here swap dup allot move + DOES> char+ aligned dup @ >r cell+ r> +; +: env-string ( str len -- ) 3 c, align dup , here over allot swap move DOES> char+ aligned dup @ >r cell+ r> ; +: env-flag ( f -- ) 4 c, c, DOES> char+ c@ 0<> ; +: env-secmode ( sm -- ) 5 c, c, DOES> char+ c@ ; + +\ create default envvars +: default-int ( n "name" -- ) create-env env-int ; +: default-bytes ( a len "name" -- ) create-env env-bytes ; +: default-string ( a len "name" -- ) create-env env-string ; +: default-flag ( f "name" -- ) create-env env-flag ; +: default-secmode ( sm "name" -- ) create-env env-secmode ; + +: set-option ( option-name len option len -- ) + 2swap encode-string + 2swap s" /options" find-node dup IF set-property ELSE drop 2drop 2drop THEN +; + +\ find an envvar's current and default value, and its type +: findenv ( name len -- adr def-adr type | 0 ) + 2dup envvars voc-find dup 0<> IF ( ABORT" not a configuration variable" ) + link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap + ELSE + nip nip + THEN +; + + +: test-flag ( param len -- true | false ) + 2dup s" true" string=ci -rot s" false" string=ci or +; + +: test-secmode ( param len -- true | false ) + 2dup s" none" string=ci -rot 2dup s" command" string=ci -rot s" full" + string=ci or or +; + +: test-int ( param len -- true | false ) + $dh-number IF false ELSE drop true THEN +; + +: findtype ( param len name len -- param len name len type ) + 2dup findenv \ try to find type of envvar + dup IF \ found a type? + nip nip + EXIT + THEN + + \ No type found yet, try to auto-detect: + drop 2swap + 2dup test-flag IF + 4 -rot \ boolean type + ELSE + 2dup test-secmode IF + 5 -rot \ secmode type + ELSE + 2dup test-int IF + 1 -rot \ integer type + ELSE + 2dup test-string + IF 3 ELSE 2 THEN \ 3 = string, 2 = default to bytes + -rot + THEN + THEN + THEN + rot + >r 2swap r> +; + +\ set an envvar +: $setenv ( param len name len -- ) + 4dup set-option + findtype + -rot $CREATE + CASE + 1 OF $dh-number IF 0 THEN env-int ENDOF \ XXX: wants decimal and 0x... + 2 OF env-bytes ENDOF + 3 OF env-string ENDOF + 4 OF evaluate env-flag ENDOF + 5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full + ENDCASE +; + +\ print an envvar +: (printenv) ( adr type -- ) + CASE + 1 OF aligned @ . ENDOF + 2 OF aligned dup cell+ swap @ swap . . ENDOF + 3 OF aligned dup @ >r cell+ r> type ENDOF + 4 OF c@ IF ." true" ELSE ." false" THEN ENDOF + 5 OF c@ . ENDOF \ XXX: print symbolically + ENDCASE +; + +: .printenv-header ( -- ) + cr + s" ---environment variable--------current value-------------default value------" + type cr +; + +DEFER old-emit +0 VALUE emit-counter + +: emit-and-count emit-counter 1 + to emit-counter old-emit ; + +: .enable-emit-counter + 0 to emit-counter + ['] emit behavior to old-emit + ['] emit-and-count to emit +; + +: .disable-emit-counter + ['] old-emit behavior to emit +; + +: .spaces ( number-of-spaces -- ) + dup 0 > IF + spaces + ELSE + drop space + THEN +; + +: .print-one-env ( name len -- ) + 3 .spaces + 2dup dup -rot type 1c swap - .spaces + findenv rot over + .enable-emit-counter + (printenv) .disable-emit-counter + 1a emit-counter - .spaces + (printenv) +; + +: .print-all-env + .printenv-header + envvars cell+ + BEGIN + @ dup + WHILE + dup link> >name + name>string .print-one-env cr + REPEAT + drop +; + +: printenv + parse-word dup 0= IF + 2drop .print-all-env + ELSE + findenv dup 0= ABORT" not a configuration variable" + rot over cr ." Current: " (printenv) + cr ." Default: " (printenv) + THEN +; + +\ set envvar(s) to default value +: (set-default) ( def-xt -- ) + dup >name name>string $CREATE dup >body c@ >r execute r> CASE + 1 OF env-int ENDOF + 2 OF env-bytes ENDOF + 3 OF env-string ENDOF + 4 OF env-flag ENDOF + 5 OF env-secmode ENDOF ENDCASE +; + +\ Environment variables might be board specific + +#include <envvar_defaults.fs> + +VARIABLE nvoff \ offset in envvar partition + +: (nvupdate-one) ( adr type -- "value" ) + CASE + 1 OF aligned @ (.d) ENDOF + 2 OF drop 0 0 ENDOF + 3 OF aligned dup @ >r cell+ r> ENDOF + 4 OF c@ IF s" true" ELSE s" false" THEN ENDOF + 5 OF c@ (.) ENDOF \ XXX: print symbolically + ENDCASE +; + +: nvupdate-one ( def-xt -- ) + >r nvram-partition-type-common get-nvram-partition ( part.addr part.len FALSE|TRUE R: def-xt ) + ABORT" No valid NVRAM." r> ( part.addr part.len def-xt ) + >name name>string ( part.addr part.len var.a var.l ) + 2dup findenv nip (nvupdate-one) + ( part.addr part.len var.addr var.len val.addr val.len ) + internal-add-env + drop +; + +: (nvupdate) ( -- ) + nvram-partition-type-common get-nvram-partition ABORT" No valid NVRAM." + erase-nvram-partition drop + envvars cell+ + BEGIN @ dup WHILE dup link> nvupdate-one REPEAT + drop +; + +: nvupdate ( -- ) + ." nvupdate is obsolete." cr +; + +: set-default + parse-word envvars voc-find + dup 0= ABORT" not a configuration variable" link> (set-default) +; + +: (set-defaults) + envvars cell+ + BEGIN @ dup WHILE dup link> (set-default) REPEAT + drop +; + +\ Preset nvram variables in RAM, but do not overwrite them in NVRAM +(set-defaults) + +: set-defaults + (set-defaults) (nvupdate) +; + +: setenv parse-word ( skipws ) 0d parse -leading 2swap $setenv (nvupdate) ; + +: get-nv ( -- ) + nvram-partition-type-common get-nvram-partition ( addr offset not-found | not-found ) \ find partition header + IF + ." No NVRAM common partition, re-initializing..." cr + internal-reset-nvram + (nvupdate) + nvram-partition-type-common get-nvram-partition IF ." NVRAM seems to be broken." cr EXIT THEN + THEN + \ partition header found: read data from nvram + drop ( addr ) \ throw away offset + BEGIN + dup rzcount dup \ make string from offset and make condition + WHILE ( offset offset length ) + 2dup [char] = split \ Split string at equal sign (=) + ( offset offset length name len param len ) + 2swap ( offset offset length param len name len ) + $setenv \ Set envvar + nip \ throw away old string begin + + 1+ \ calc new offset + REPEAT + 2drop drop \ cleanup +; + +get-nv + +: check-for-nvramrc ( -- ) + use-nvramrc? IF + s" Executing following code from nvramrc: " + s" nvramrc" evaluate $cat + nvramlog-write-string-cr + s" (!) Executing code specified in nvramrc" type + cr s" SLOF Setup = " type + \ to remove the string from the console if the nvramrc is broken + \ we need to know how many chars are printed + .enable-emit-counter + s" nvramrc" evaluate ['] evaluate CATCH IF + \ dropping the rest of the nvram string + 2drop + \ delete the chars we do not want to see + emit-counter 0 DO 8 emit LOOP + s" (!) Code in nvramrc triggered exception. " + 2dup nvramlog-write-string + type cr 12 spaces s" Aborting nvramrc execution" 2dup + nvramlog-write-string-cr type cr + s" SLOF Setup = " type + THEN + .disable-emit-counter + THEN +; + + +: (nv-findalias) ( alias-ptr alias-len -- pos ) + \ create a temporary empty string + here 0 + \ append "devalias " to the temporary string + s" devalias " string-cat + \ append "<name-str>" to the temporary string + 3 pick 3 pick string-cat + \ append a SPACE character to the temporary string + s" " string-cat + \ get nvramrc + s" nvramrc" evaluate + \ get position of the temporary string inside of nvramrc + 2swap find-substr + nip nip +; + +: (nv-build-real-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len ) + \ create a temporary empty string + 2swap here 0 + \ append "devalias " to the temporary string + s" devalias " string-cat + \ append "<name-ptr>" to the temporary string + 2swap string-cat + \ append a SPACE character to the temporary string + s" " string-cat + \ append "<dev-ptr> to the temporary string + 2swap string-cat + \ append a CR character to the temporary string + 0d char-cat + \ append a LF character to the temporary string + 0a char-cat +; + +: (nv-build-null-entry) ( name-ptr name-len dev-ptr dev-len -- str-ptr str-len ) + 4drop here 0 +; + +: (nv-build-nvramrc) ( name-str name-len dev-str dev-len xt-build-entry -- ) + \ *** PART 1: check if there is still an alias definition available *** + ( alias-ptr alias-len path-ptr path-ptr call-build-entry alias-pos ) + 4 pick 4 pick (nv-findalias) + \ if our alias definition is a new one + dup s" nvramrc" evaluate nip >= IF + \ call-build-entry + drop execute + \ append content of "nvramrc" to the temporary string + s" nvramrc" evaluate string-cat + \ Allocate the temporary string + dup allot + \ write the string into nvramrc + s" nvramrc" $setenv + ELSE \ if our alias is still defined in nvramrc + \ *** PART 2: calculate the memory size for the new content of nvramrc *** + \ add number of bytes needed for nvramrc-prefix to number of bytes needed + \ for the new entry + 5 pick 5 pick 5 pick 5 pick 5 pick execute nip over + + ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos tmp-len ) + \ add number of bytes needed for nvramrc-postfix + s" nvramrc" evaluate 3 pick string-at + 2dup find-nextline string-at nip + + \ *** PART 3: build the new content *** + \ allocate enough memory for new content + alloc-mem 0 + ( alias-ptr alias-len path-ptr path-ptr build-entry-xt alias-pos mem len ) + \ add nvramrc-prefix + s" nvramrc" evaluate drop 3 pick string-cat + \ add new entry + rot >r >r >r execute r> r> 2swap string-cat + ( mem, len ) ( R: alias-pos ) + \ add nvramrc-postfix + s" nvramrc" evaluate r> string-at + 2dup find-nextline string-at string-cat + ( mem len ) + \ write the temporary string into nvramrc and clean up memory + 2dup s" nvramrc" $setenv free-mem + THEN +; + +: $nvalias ( name-str name-len dev-str dev-len -- ) + 4dup ['] (nv-build-real-entry) (nv-build-nvramrc) + set-alias + s" true" s" use-nvramrc?" $setenv + (nvupdate) +; + +: nvalias ( "alias-name< >device-specifier<eol>" -- ) + parse-word parse-word dup 0<> IF + $nvalias + ELSE + 2drop 2drop + cr + " Usage: nvalias (""alias-name< >device-specifier<eol>"" -- )" type + cr + THEN +; + +: $nvunalias ( name-str name-len -- ) + s" " ['] (nv-build-null-entry) (nv-build-nvramrc) + (nvupdate) +; + +: nvunalias ( "alias-name< >" -- ) + parse-word $nvunalias +; + +: diagnostic-mode? ( -- diag-switch? ) diag-switch? ; + diff --git a/src/roms/SLOF/slof/fs/envvar_defaults.fs b/src/roms/SLOF/slof/fs/envvar_defaults.fs new file mode 100644 index 0000000..86716ef --- /dev/null +++ b/src/roms/SLOF/slof/fs/envvar_defaults.fs @@ -0,0 +1,44 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ the defaults +\ some of those are platform dependent, and should e.g. be +\ created from VPD values +true default-flag auto-boot? +s" " default-string boot-device +s" " default-string boot-file +s" boot" default-string boot-command +s" " default-string diag-device +s" " default-string diag-file +false default-flag diag-switch? +true default-flag fcode-debug? +s" " default-string input-device +s" " default-string nvramrc +s" " default-string oem-banner +false default-flag oem-banner? +0 0 default-bytes oem-logo +false default-flag oem-logo? +s" " default-string output-device +200 default-int screen-#columns +200 default-int screen-#rows +0 default-int security-#badlogins +0 default-secmode security-mode +s" " default-string security-password +0 default-int selftest-#megs +false default-flag use-nvramrc? +false default-flag direct-serial? +true default-flag real-mode? +default-load-base default-int load-base +#ifdef BIOSEMU +true default-flag use-biosemu? +0 default-int biosemu-debug +#endif diff --git a/src/roms/SLOF/slof/fs/exception.fs b/src/roms/SLOF/slof/fs/exception.fs new file mode 100644 index 0000000..dbf11fb --- /dev/null +++ b/src/roms/SLOF/slof/fs/exception.fs @@ -0,0 +1,154 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +STRUCT + cell FIELD >r0 cell FIELD >r1 cell FIELD >r2 cell FIELD >r3 + cell FIELD >r4 cell FIELD >r5 cell FIELD >r6 cell FIELD >r7 + cell FIELD >r8 cell FIELD >r9 cell FIELD >r10 cell FIELD >r11 + cell FIELD >r12 cell FIELD >r13 cell FIELD >r14 cell FIELD >r15 + cell FIELD >r16 cell FIELD >r17 cell FIELD >r18 cell FIELD >r19 + cell FIELD >r20 cell FIELD >r21 cell FIELD >r22 cell FIELD >r23 + cell FIELD >r24 cell FIELD >r25 cell FIELD >r26 cell FIELD >r27 + cell FIELD >r28 cell FIELD >r29 cell FIELD >r30 cell FIELD >r31 + cell FIELD >cr cell FIELD >xer cell FIELD >lr cell FIELD >ctr + cell FIELD >srr0 cell FIELD >srr1 cell FIELD >dar cell FIELD >dsisr +CONSTANT ciregs-size + + + +: .16 10 0.r 3 spaces ; +: .8 8 spaces 8 0.r 3 spaces ; +: .4regs cr 4 0 DO dup @ .16 8 cells+ LOOP drop ; +: .fixed-regs + cr ." R0 .. R7 R8 .. R15 R16 .. R23 R24 .. R31" + dup 8 0 DO dup .4regs cell+ LOOP drop +; + +: .special-regs + cr ." CR / XER LR / CTR SRR0 / SRR1 DAR / DSISR" + cr dup >cr @ .8 dup >lr @ .16 dup >srr0 @ .16 dup >dar @ .16 + cr dup >xer @ .16 dup >ctr @ .16 dup >srr1 @ .16 >dsisr @ .8 +; + +: .regs + cr .fixed-regs + cr .special-regs + cr cr +; + +: .hw-exception ( reason-code exception-nr -- ) + ." ( " dup . ." ) " + CASE + 200 OF ." Machine Check" ENDOF + 300 OF ." Data Storage" ENDOF + 380 OF ." Data Segment" ENDOF + 400 OF ." Instruction Storage" ENDOF + 480 OF ." Instruction Segment" ENDOF + 500 OF ." External" ENDOF + 600 OF ." Alignment" ENDOF + 700 OF ." Program" ENDOF + 800 OF ." Floating-point unavailable" ENDOF + 900 OF ." Decrementer" ENDOF + 980 OF ." Hypervisor Decrementer" ENDOF + C00 OF ." System Call" ENDOF + D00 OF ." Trace" ENDOF + F00 OF ." Performance Monitor" ENDOF + F20 OF ." VMX Unavailable" ENDOF + 1200 OF ." System Error" ENDOF + 1600 OF ." Maintenance" ENDOF + 1800 OF ." Thermal" ENDOF + dup OF ." Unknown" ENDOF + ENDCASE + ." Exception [ " . ." ]" +; + +: .sw-exception ( exception-nr -- ) + ." Exception [ " . ." ] triggered by boot firmware." +; + +\ this word gets also called for non-hardware exceptions. +: be-hw-exception ( [reason-code] exception-nr -- ) + cr cr + dup 0> IF .hw-exception ELSE .sw-exception THEN + cr eregs .regs +; +' be-hw-exception to hw-exception-handler + +: (boot-exception-handler) ( x1...xn exception-nr -- x1...xn) + dup IF + dup 0 > IF + negate cp 9 emit ." : " type + ELSE + CASE + -6d OF cr ." W3411: Client application returned." cr ENDOF + -6c OF cr ." E3400: It was not possible to boot from any device " + ." specified in the VPD." cr + ENDOF + -6b OF cr ." E3410: Boot list successfully read from VPD " + ." but no useful information received." cr + ENDOF + -6a OF cr ." E3420: Boot list could not be read from VPD." cr + ENDOF + -69 OF + cr ." E3406: Client application returned an error" + abort"-str @ count dup IF + ." : " type cr + ELSE + ." ." cr + 2drop + THEN + ENDOF + -68 OF cr ." E3405: No such device" cr ENDOF + -67 OF cr ." E3404: Not a bootable device!" cr ENDOF + -66 OF cr ." E3408: Failed to claim memory for the executable" cr + ENDOF + -65 OF cr ." E3407: Load failed" cr ENDOF + -64 OF cr ." E3403: Bad executable: " abort"-str @ count type cr + ENDOF + -63 OF cr ." E3409: Unknown FORTH Word" cr ENDOF + -2 OF cr ." E3401: Aborting boot, " abort"-str @ count type cr + ENDOF + dup OF ." E3402: Aborting boot, internal error" cr ENDOF + ENDCASE + THEN + ELSE + drop + THEN +; + +' (boot-exception-handler) to boot-exception-handler + +: throw-error ( error-code "error-string" -- ) + skipws 0a parse rot throw +; + +\ Enable external interrupt in msr + +: enable-ext-int ( -- ) + msr@ 8000 or msr! +; + +\ Disable external interrupt in msr + +: disable-ext-int ( -- ) + msr@ 8000 not and msr! +; + +\ Generate external interrupt through Internal Interrupt Controller of BE + +: gen-ext-int ( -- ) + 7fffffff dec! \ Reset decrementer + enable-ext-int \ Enable interrupt + FF 20000508418 rx! \ Interrupt priority mask + 10 20000508410 rx! \ Interrupt priority +; + diff --git a/src/roms/SLOF/slof/fs/fbuffer.fs b/src/roms/SLOF/slof/fs/fbuffer.fs new file mode 100644 index 0000000..4704608 --- /dev/null +++ b/src/roms/SLOF/slof/fs/fbuffer.fs @@ -0,0 +1,266 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +#include "terminal.fs" +#include "display.fs" + +\ \\\\\\\\\\\\\\ Global Data + +0 VALUE frame-buffer-adr +0 VALUE screen-height +0 VALUE screen-width +0 VALUE screen-depth +0 VALUE screen-line-bytes +0 VALUE window-top +0 VALUE window-left + +0 VALUE .sc + +: screen-#rows ( -- rows ) + .sc IF + screen-height char-height / + ELSE + true to .sc + s" screen-#rows" eval + false to .sc + THEN +; + +: screen-#columns ( -- columns ) + .sc IF + screen-width char-width / + ELSE + true to .sc + s" screen-#columns" eval + false to .sc + THEN +; + +\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods + + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ * +\ * + +: fb8-background inverse? ; +: fb8-foreground inverse? invert ; + +: fb8-lines2bytes ( #lines -- #bytes ) char-height * screen-line-bytes * ; +: fb8-columns2bytes ( #columns -- #bytes ) char-width * screen-depth * ; +: fb8-line2addr ( line# -- addr ) + char-height * window-top + screen-line-bytes * + frame-buffer-adr + window-left screen-depth * + +; + +: fb8-erase-block ( addr len ) fb8-background rfill ; + + +0 VALUE .ab +CREATE bitmap-buffer 400 4 * allot + +: active-bits ( -- new ) .ab dup 8 > IF 8 - to .ab 8 ELSE + char-width to .ab ?dup 0= IF recurse THEN + THEN ; + +: fb8-char2bitmap ( font-height font-addr -- bitmap-buffer ) + bitmap-buffer >r + char-height rot 0> IF r> char-width 2dup fb8-erase-block + >r 1- THEN + + r> -rot char-width to .ab + ( fb-addr font-addr font-height ) + fontbytes * bounds ?DO + i c@ active-bits 0 ?DO + dup 80 and IF fb8-foreground ELSE fb8-background THEN + ( fb-addr fbyte colr ) 2 pick ! 1 lshift + swap screen-depth + swap + LOOP drop + LOOP drop + bitmap-buffer +; + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ * IEEE 1275: Frame buffer support routines +\ * + +: fb8-draw-logo ( line# addr width height -- ) ." fb8-draw-logo ( " .s ." )" cr + 2drop 2drop +; + +: fb8-toggle-cursor ( -- ) + line# fb8-line2addr column# fb8-columns2bytes + + char-height 2 - screen-line-bytes * + + 2 0 ?DO + dup char-width screen-depth * invert-region + screen-line-bytes + + LOOP drop +; + +: fb8-draw-character ( char -- ) + >r default-font over + r@ -rot between IF + 2swap 3drop r> >font fb8-char2bitmap ( bitmap-buf ) + line# fb8-line2addr column# fb8-columns2bytes + ( bitmap-buf fb-addr ) + char-height 0 ?DO + 2dup char-width screen-depth * mrmove + screen-line-bytes + >r char-width screen-depth * + r> + LOOP 2drop + ELSE 2drop r> 3drop THEN +; + +: fb8-insert-lines ( n -- ) + fb8-lines2bytes >r line# fb8-line2addr dup dup r@ + + #lines line# - fb8-lines2bytes r@ - rmove + r> fb8-erase-block +; + +: fb8-delete-lines ( n -- ) + fb8-lines2bytes >r line# fb8-line2addr dup dup r@ + swap + #lines fb8-lines2bytes r@ - dup >r rmove + r> + r> fb8-erase-block +; + +: fb8-insert-characters ( n -- ) + line# fb8-line2addr column# fb8-columns2bytes + >r + #columns column# - 2dup >= IF + nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN + ELSE + fb8-columns2bytes swap fb8-columns2bytes tuck - + over r@ tuck + rot char-height 0 ?DO + 3dup rmove + -rot screen-line-bytes tuck + -rot + swap rot + LOOP + 3drop r> + THEN + char-height 0 ?DO + dup 2 pick fb8-erase-block screen-line-bytes + + LOOP + 2drop +; + +: fb8-delete-characters ( n -- ) + line# fb8-line2addr column# fb8-columns2bytes + >r + #columns column# - 2dup >= IF + nip dup 0> IF fb8-columns2bytes r> ELSE r> 2drop EXIT THEN + ELSE + fb8-columns2bytes swap fb8-columns2bytes tuck - + over r@ + 2dup + r> swap >r rot char-height 0 ?DO + 3dup rmove + -rot screen-line-bytes tuck + -rot + swap rot + LOOP + 3drop r> over - + THEN + char-height 0 ?DO + dup 2 pick fb8-erase-block screen-line-bytes + + LOOP + 2drop +; + +: fb8-reset-screen ( -- ) ( Left as no-op by design ) ; + +: fb8-erase-screen ( -- ) + frame-buffer-adr screen-height screen-line-bytes * fb8-erase-block +; + +: fb8-invert-screen ( -- ) + frame-buffer-adr screen-height screen-line-bytes * invert-region +; + +: fb8-blink-screen ( -- ) fb8-invert-screen fb8-invert-screen ; + +: fb8-install ( width height #columns #lines -- ) + 1 to screen-depth + 2swap to screen-height to screen-width + screen-width to screen-line-bytes + screen-#rows min to #lines + screen-#columns min to #columns + screen-height char-height #lines * - 2/ to window-top + screen-width char-width #columns * - 2/ to window-left + ['] fb8-toggle-cursor to toggle-cursor + ['] fb8-draw-character to draw-character + ['] fb8-insert-lines to insert-lines + ['] fb8-delete-lines to delete-lines + ['] fb8-insert-characters to insert-characters + ['] fb8-delete-characters to delete-characters + ['] fb8-erase-screen to erase-screen + ['] fb8-blink-screen to blink-screen + ['] fb8-invert-screen to invert-screen + ['] fb8-reset-screen to reset-screen + ['] fb8-draw-logo to draw-logo +; + +: fb-install ( width height #columns #lines depth -- ) + >r + fb8-install + r> to screen-depth + screen-width screen-depth * to screen-line-bytes +; + + +\ Install display related FCODE evaluator tokens +: fb8-set-tokens ( -- ) + ['] is-install 0 11C set-token + ['] is-remove 0 11D set-token + ['] is-selftest 0 11E set-token + + ['] #lines 0 150 set-token + ['] #columns 0 151 set-token + ['] line# 0 152 set-token + ['] column# 0 153 set-token + ['] inverse? 0 154 set-token + ['] inverse-screen? 0 155 set-token + ['] draw-character 0 157 set-token + ['] reset-screen 0 158 set-token + ['] toggle-cursor 0 159 set-token + ['] erase-screen 0 15A set-token + ['] blink-screen 0 15B set-token + ['] invert-screen 0 15C set-token + ['] insert-characters 0 15D set-token + ['] delete-characters 0 15E set-token + ['] insert-lines 0 15F set-token + ['] delete-lines 0 160 set-token + ['] draw-logo 0 161 set-token + ['] frame-buffer-adr 0 162 set-token + ['] screen-height 0 163 set-token + ['] screen-width 0 164 set-token + ['] window-top 0 165 set-token + ['] window-left 0 166 set-token + \ ['] foreground-color 0 168 set-token \ 16-color extension - n/a + \ ['] background-color 0 169 set-token \ 16-color extension - n/a + ['] default-font 0 16A set-token + ['] set-font 0 16B set-token + ['] char-height 0 16C set-token + ['] char-width 0 16D set-token + ['] >font 0 16E set-token + ['] fontbytes 0 16F set-token + + ['] fb8-draw-character 0 180 set-token + ['] fb8-reset-screen 0 181 set-token + ['] fb8-toggle-cursor 0 182 set-token + ['] fb8-erase-screen 0 183 set-token + ['] fb8-blink-screen 0 184 set-token + ['] fb8-invert-screen 0 185 set-token + ['] fb8-insert-characters 0 186 set-token + ['] fb8-delete-characters 0 187 set-token + ['] fb8-insert-lines 0 188 set-token + ['] fb8-delete-lines 0 189 set-token + ['] fb8-draw-logo 0 18A set-token + ['] fb8-install 0 18B set-token +; +fb8-set-tokens + + +\ \\\\\\\\\\\\ Debug Stuff \\\\\\\\\\\\\\\\ + +: fb8-dump-bitmap cr char-height 0 ?do char-width 0 ?do dup c@ if ." @" else ." ." then 1+ loop cr loop drop ; + +: fb8-dump-char >font -b swap fb8-char2bitmap fb8-dump-bitmap ; diff --git a/src/roms/SLOF/slof/fs/fcode/1275.fs b/src/roms/SLOF/slof/fs/fcode/1275.fs new file mode 100644 index 0000000..c2a67bc --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/1275.fs @@ -0,0 +1,465 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +: fcode-revision ( -- n ) + 00030000 \ major * 65536 + minor + ; + +: b(lit) ( -- n ) + next-ip read-fcode-num32 + ?compile-mode IF literal, THEN + ; + +: b(") + next-ip read-fcode-string + ?compile-mode IF fc-string, align postpone count THEN + ; + +: b(') + next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN + ; + +: ?jump-direction ( n -- ) + dup 8000 >= IF + 10000 - \ Create cell-sized negative value + THEN + fcode-offset - \ IP is already behind offset, so subtract offset size +; + +: ?negative + 8000 and + ; + +: dest-on-top + 0 >r BEGIN dup @ 0= WHILE >r REPEAT + BEGIN r> dup WHILE swap REPEAT + drop + ; + +: read-fcode-offset + next-ip + ?offset16 IF + read-fcode-num16 + ELSE + read-byte + dup 80 and IF FF00 or THEN \ Fake 16-bit signed offset + THEN +; + +: b?branch ( flag -- ) + ?compile-mode IF + read-fcode-offset ?negative IF + dest-on-top postpone until + ELSE + postpone if + THEN + ELSE + ( flag ) IF + fcode-offset jump-n-ip \ Skip over offset value + ELSE + read-fcode-offset + ?jump-direction jump-n-ip + THEN + THEN +; immediate + +: bbranch ( -- ) + ?compile-mode IF + read-fcode-offset + ?negative IF + dest-on-top postpone again + ELSE + postpone else + get-ip next-ip fcode@ B2 = IF + drop + ELSE + set-ip + THEN + THEN + ELSE + read-fcode-offset ?jump-direction jump-n-ip + THEN +; immediate + +: b(<mark) ( -- ) + ?compile-mode IF postpone begin THEN + ; immediate + +: b(>resolve) ( -- ) + ?compile-mode IF postpone then THEN + ; immediate + +: b(;) + <semicolon> compile, reveal + postpone [ +; immediate + +: b(:) ( -- ) + <colon> compile, ] + ; immediate + +: b(case) ( sel -- sel ) + postpone case + ; immediate + +: b(endcase) + postpone endcase + ; immediate + +: b(of) + postpone of + read-fcode-offset drop \ read and discard offset + ; immediate + +: b(endof) + postpone endof + read-fcode-offset drop + ; immediate + +: b(do) + postpone do + read-fcode-offset drop + ; immediate + +: b(?do) + postpone ?do + read-fcode-offset drop + ; immediate + +: b(loop) + postpone loop + read-fcode-offset drop + ; immediate + +: b(+loop) + postpone +loop + read-fcode-offset drop + ; immediate + +: b(leave) + postpone leave + ; immediate + + +0 VALUE fc-instance? +: fc-instance ( -- ) \ Mark next defining word as instance-specific. + TRUE TO fc-instance? +; + +: new-token \ unnamed local fcode function + align here next-ip read-fcode# 0 swap set-token + ; + +: external-token ( -- ) \ named local fcode function + next-ip read-fcode-string + \ fc-instance? IF cr ." ext instance token: " 2dup type ." in " pwd cr THEN + header ( str len -- ) \ create a header in the current dictionary entry + new-token + ; + +: new-token + eva-debug? IF + s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup + header + THEN + new-token +; + +\ decide wether or not to give a new token an own name in the dictionary +: named-token + fcode-debug? IF + external-token + ELSE + next-ip read-fcode-string 2drop \ Forget about the name + new-token + THEN +; + +: b(to) ( val -- ) + next-ip read-fcode# + get-token drop ( val xt ) + dup @ ( val xt @xt ) + dup <value> = over <defer> = OR IF + \ Destination is value or defer + drop + >body cell - + ( val addr ) + ?compile-mode IF + literal, postpone ! + ELSE + ! + THEN + ELSE + <create> <> IF ( val xt ) + TRUE ABORT" Invalid destination for FCODE b(to)" + THEN + dup cell+ @ ( val xt @xt+1cell ) + dup <instancevalue> <> swap <instancedefer> <> AND IF + TRUE ABORT" Invalid destination for FCODE b(to)" + THEN + \ Destination is instance-value or instance-defer + >body @ ( val instance-offset ) + ?compile-mode IF + literal, postpone >instance postpone ! + ELSE + >instance ! + THEN + ELSE + THEN +; immediate + +: b(value) + fc-instance? IF + <create> , \ Needed for "(instance?)" for example + <instancevalue> , + (create-instance-var) + FALSE TO fc-instance? + ELSE + <value> , , + THEN + reveal +; + +: b(variable) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancevariable> , + 0 (create-instance-var) + FALSE TO fc-instance? + ELSE + <variable> , 0 , + THEN + reveal +; + +: b(constant) + <constant> , , reveal + ; + +: undefined-defer + cr cr ." Uninitialized defer word has been executed!" cr cr + true fcode-end ! + ; + +: b(defer) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancedefer> , + ['] undefined-defer (create-instance-var) + reveal + FALSE TO fc-instance? + ELSE + <defer> , reveal + postpone undefined-defer + THEN +; + +: b(create) + <variable> , + postpone noop reveal + ; + +: b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) + <colon> , over literal, + postpone + + <semicolon> compile, + reveal + + +; + +: b(buffer:) ( E: -- a-addr) ( F: size -- ) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancebuffer> , + (create-instance-buf) + FALSE TO fc-instance? + ELSE + <buffer:> , allot + THEN + reveal +; + +: suspend-fcode ( -- ) + noop \ has to be implemented more efficiently ;-) + ; + +: offset16 ( -- ) + 2 to fcode-offset + ; + +: version1 ( -- ) + 1 to fcode-spread + 1 to fcode-offset + read-header + ; + +: start0 ( -- ) + 0 to fcode-spread + offset16 + read-header + ; + +: start1 ( -- ) + 1 to fcode-spread + offset16 + read-header + ; + +: start2 ( -- ) + 2 to fcode-spread + offset16 + read-header + ; + +: start4 ( -- ) + 4 to fcode-spread + offset16 + read-header + ; + +: end0 ( -- ) + true fcode-end ! + ; + +: end1 ( -- ) + end0 + ; + +: ferror ( -- ) + clear end0 + cr ." FCode# " fcode-num @ . ." not assigned!" + cr ." FCode evaluation aborted." cr + ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr + abort + ; + +: reset-local-fcodes + FFF 800 DO ['] ferror 0 i set-token LOOP + ; + +: byte-load ( addr xt -- ) + >r >r + save-evaluator-state + r> r> + reset-fcode-end + 1 to fcode-spread + dup 1 = IF drop ['] rb@ THEN to fcode-rb@ + set-ip + reset-local-fcodes + depth >r + evaluate-fcode + r> depth 1- <> IF + clear end0 + cr ." Ambiguous stack depth after byte-load!" + cr ." FCode evaluation aborted." cr cr + ELSE + restore-evaluator-state + THEN + ['] c@ to fcode-rb@ +; + +\ Functions for accessing memory ... since some FCODE programs use the normal +\ memory access functions for accessing MMIO memory, too, we got to use a little +\ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the +\ FCODE is trying to access MMIO memory and use the register based access +\ functions instead! +: fc-c@ ( addr -- byte ) dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ; +: fc-w@ ( addr -- word ) dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ; +: fc-<w@ ( addr -- word ) fc-w@ dup 8000 >= IF 10000 - THEN ; +: fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ; +: fc-<l@ ( addr -- long ) fc-l@ signed ; +: fc-x@ ( addr -- dlong ) dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ; +: fc-c! ( byte addr -- ) dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ; +: fc-w! ( word addr -- ) dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ; +: fc-l! ( long addr -- ) dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ; +: fc-x! ( dlong addr -- ) dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ; + +: fc-fill ( add len byte -- ) 2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ; +: fc-move ( src dst len -- ) + 2 pick MIN-RAM-SIZE > \ Check src + 2 pick MIN-RAM-SIZE > \ Check dst + OR IF rmove ELSE move THEN +; + +\ Destroy virtual mapping (should maybe also update "address" property here?) +: free-virtual ( virt size -- ) + s" map-out" $call-parent +; + +\ Map the specified region, return virtual address +: map-low ( phys.lo ... size -- virt ) + my-space swap s" map-in" $call-parent +; + +\ Get MAC address +: mac-address ( -- mac-str mac-len ) + s" local-mac-address" get-my-property IF + 0 0 + THEN +; + +\ Output line and column number - not used yet +VARIABLE #line +0 #line ! +VARIABLE #out +0 #out ! + +\ Display device status +: display-status ( n -- ) + ." Device status: " . cr +; + +\ Obsolete variables: +VARIABLE group-code +0 group-code ! + +\ Obsolete: Allocate memory for DMA +: dma-alloc ( byte -- virtual ) + s" dma-alloc" $call-parent +; + +\ Obsolete: Get params property +: my-params ( -- addr len ) + s" params" get-my-property IF + 0 0 + THEN +; + +\ Obsolete: Convert SBus interrupt level to CPU interrupt level +: sbus-intr>cpu ( sbus-intr# -- cpu-intr# ) +; + +\ Obsolete: Set "intr" property +: intr ( interrupt# vector -- ) + >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property +; + +\ Obsolete: Create the "name" property +: driver ( addr len -- ) + encode-string s" name" property +; + +\ Obsolete: Return type of CPU +: processor-type ( -- cpu-type ) + 0 +; + +\ Obsolete: Return firmware version +: firmware-version ( -- n ) + 10000 \ Just a dummy value +; + +\ Obsolete: Return fcode-version +: fcode-version ( -- n ) + fcode-revision +; diff --git a/src/roms/SLOF/slof/fs/fcode/core.fs b/src/roms/SLOF/slof/fs/fcode/core.fs new file mode 100644 index 0000000..8fd98ec --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/core.fs @@ -0,0 +1,173 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: ?offset16 ( -- true|false ) + fcode-offset 2 = + ; + +: ?arch64 ( -- true|false ) + cell 8 = + ; + +: ?bigendian ( -- true|false ) + deadbeef fcode-num ! + fcode-num ?arch64 IF 4 + THEN + c@ de = + ; + +: reset-fcode-end ( -- ) + false fcode-end ! + ; + +: get-ip ( -- n ) + ip @ + ; + +: set-ip ( n -- ) + ip ! + ; + +: next-ip ( -- ) + get-ip 1+ set-ip + ; + +: jump-n-ip ( n -- ) + get-ip + set-ip + ; + +: read-byte ( -- n ) + get-ip fcode-rb@ + ; + +: ?compile-mode ( -- on|off ) + state @ + ; + +: save-evaluator-state + get-ip eva-debug? IF ." saved ip " dup . cr THEN + fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN + fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN +\ local fcodes are currently NOT saved! + fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN + ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN + ; + +: restore-evaluator-state + eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@ + eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread +\ local fcodes are currently NOT restored! + eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset + eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end ! + eva-debug? IF ." restored ip " dup . cr THEN set-ip + ; + +: token-table-index ( fcode# -- addr ) + cells token-table + + ; + +: join-immediate ( xt immediate? addr -- xt+immediate? addr ) + -rot + swap + ; + +: split-immediate ( xt+immediate? -- xt immediate? ) + dup 1 and 2dup - rot drop swap + ; + +: literal, ( n -- ) + postpone literal + ; + +: fc-string, + postpone sliteral + dup c, bounds ?do i c@ c, loop + ; + +: set-token ( xt immediate? fcode# -- ) + token-table-index join-immediate ! + ; + +: get-token ( fcode# -- xt immediate? ) + token-table-index @ split-immediate + ; + +( ---------------------------------------------------- ) + +#include "little-big.fs" + +( ---------------------------------------------------- ) + +: read-fcode# ( -- FCode# ) + read-byte + dup 01 0F between IF drop read-fcode-num16 THEN + ; + +: read-header ( adr -- ) + next-ip read-byte drop + next-ip read-fcode-num16 drop + next-ip read-fcode-num32 drop + ; + +: read-fcode-string ( -- str len ) + read-byte \ get string length ( -- len ) + next-ip get-ip \ get string addr ( -- len str ) + swap \ type needs the parameters swapped ( -- str len ) + dup 1- jump-n-ip \ jump to the end of the string in FCode + ; + + +-1 VALUE break-fcode-addr +0 VALUE break-fcode-steps + +: evaluate-fcode ( -- ) + BEGIN + get-ip break-fcode-addr = IF + TRUE fcode-end ! + THEN + fcode-end @ 0= + WHILE + fcode@ ( fcode# ) + eva-debug? IF + dup + get-ip 8 u.r ." : " + ." [" 3 u.r ." ] " + THEN + \ When it is not immediate and in compile-mode, then compile + get-token 0= ?compile-mode AND IF ( xt ) + compile, + ELSE \ immediate or "interpretation" mode + eva-debug? IF dup xt>name type space THEN + execute + THEN + eva-debug? IF .s cr THEN + break-fcode-steps IF + break-fcode-steps 1- TO break-fcode-steps + break-fcode-steps 0= IF + TRUE fcode-end ! + THEN + THEN + next-ip + REPEAT +; + +\ Run FCODE for n steps +: steps-fcode ( n -- ) + to break-fcode-steps + break-fcode-addr >r -1 to break-fcode-addr + reset-fcode-end + evaluate-fcode + r> to break-fcode-addr +; + +\ Step through one FCODE instruction +: step-fcode ( -- ) + 1 steps-fcode +; diff --git a/src/roms/SLOF/slof/fs/fcode/evaluator.fs b/src/roms/SLOF/slof/fs/fcode/evaluator.fs new file mode 100644 index 0000000..8f0bae5 --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/evaluator.fs @@ -0,0 +1,119 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +variable ip +variable fcode-end +variable fcode-num + 1 value fcode-spread + 2 value fcode-offset +false value eva-debug? +true value fcode-debug? +defer fcode-rb@ +defer fcode@ + +' c@ to fcode-rb@ + +create token-table 2000 cells allot \ 1000h = 4096d + +#include "core.fs" +#include "1275.fs" +#include "tokens.fs" +#include "locals.fs" + +0 value buff +0 value buff-size + +' read-fcode# to fcode@ + +( ---------------------------------------------------- ) + +: execute-rom-fcode ( addr len | false -- ) + reset-fcode-end + ?dup IF + diagnostic-mode? IF ." , executing ..." cr THEN + dup >r r@ alloc-mem dup >r swap rmove + r@ set-ip evaluate-fcode + diagnostic-mode? IF ." Done." cr THEN + r> r> free-mem + THEN +; + +: rom-code-ignored ( image-addr name len -- image-addr ) + diagnostic-mode? IF + type ." code found in image " dup . ." , ignoring ..." cr + ELSE + 2drop + THEN +; + +: pci-find-rom ( baseaddr -- addr ) + dup IF + dup rw@-le aa55 = IF + diagnostic-mode? IF ." Device ROM header found at " dup . cr THEN + ELSE + drop 0 + THEN + THEN +; + +: pci-find-fcode ( baseaddr -- addr len | false ) + BEGIN + 1ff NOT and \ Image must start at 512 byte boundary + pci-find-rom dup + WHILE + dup 18 + rw@-le + ( pcir-addr ) + \ Check for PCIR magic ... since pcir-addr might not be + \ 4-byte aligned, we've got to use two reads here: + dup rw@-le 4350 ( 'PC' ) <> ( pcir-addr hasPC? ) + over 2+ rw@-le 5249 ( 'IR' ) <> OR IF + diagnostic-mode? IF + ." Invalid PCI Data structure, ignoring ROM contents" cr + THEN + drop false EXIT + THEN ( pcir-addr ) + dup 14 + rb@ CASE \ Get image code type + 0 OF s" Intel x86 BIOS" rom-code-ignored ENDOF + 1 OF + diagnostic-mode? IF + ." Open Firmware FCode found in image at " dup . cr + THEN + dup 1ff NOT AND \ Back to the ROM image header + dup 2+ rw@-le + \ Pointer to FCODE (PCI bus binding ch.9) + swap 10 + rw@-le 200 * \ Image length + EXIT + ENDOF + 2 OF s" HP PA RISC" rom-code-ignored ENDOF + 3 OF s" EFI" rom-code-ignored ENDOF + dup OF s" Unknown type" rom-code-ignored ENDOF + ENDCASE + dup 15 + rb@ 80 and IF \ End of last image? + drop false EXIT + THEN + dup 10 + rw@-le 200 * + \ Next image start + REPEAT +; + + +\ Prepare and run a FCODE program from a PCI Option ROM. +: pci-execute-fcode ( baseaddr -- ) + pci-find-fcode dup 0= IF + 2drop EXIT + THEN ( addr len ) + fc-set-pci-mmio-tokens \ Prepare PCI access functions + \ Now run the FCODE: + ['] execute-rom-fcode CATCH IF + cr ." FCODE failed!" cr + 2drop + THEN + fc-set-normal-mmio-tokens \ Restore normal MMIO access functions +; diff --git a/src/roms/SLOF/slof/fs/fcode/little-big.fs b/src/roms/SLOF/slof/fs/fcode/little-big.fs new file mode 100644 index 0000000..309c626 --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/little-big.fs @@ -0,0 +1,96 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ little- and big-endian FCODE IP access functions + + +?bigendian [IF] \ Big endian access functions first + + +: read-fcode-num16 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 7 + C! + ELSE + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 3 + C! + THEN + fcode-num @ +; + +: read-fcode-num32 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 4 + C! + next-ip + read-byte fcode-num 5 + C! + next-ip + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 7 + C! + ELSE + read-byte fcode-num 0 + C! + next-ip + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 3 + C! + THEN + fcode-num @ +; + + +[ELSE] \ Now the little endian access functions + + +: read-fcode-num16 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 7 + C! + next-ip + read-byte fcode-num 6 + C! + ELSE + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 0 + C! + THEN + fcode-num @ +; + +: read-fcode-num32 ( adr -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 7 + C! + next-ip + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 5 + C! + next-ip + read-byte fcode-num 4 + C! + ELSE + read-byte fcode-num 3 + C! + next-ip + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 0 + C! + THEN + fcode-num @ +; + + +[THEN] diff --git a/src/roms/SLOF/slof/fs/fcode/locals.fs b/src/roms/SLOF/slof/fs/fcode/locals.fs new file mode 100644 index 0000000..5381df0 --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/locals.fs @@ -0,0 +1,155 @@ +\ ***************************************************************************** +\ * Copyright (c) 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ * +\ * Support for old-fashioned local values in FCODE. +\ * +\ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range +\ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack +\ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to +\ * push 0 up to 8 values from the normal data stack into the current locals +\ * stack frame. All other variables in the current stack frame are not +\ * pre-initialized. +\ * The opcodes from 0x410 to 0x417 can be used for reading the first, second, +\ * ... eighth value out of the locals stack frame, and the opcode from 0x418 +\ * to 0x41f can be used to set the first, second, ... eighth value in the +\ * stack frame respectively. +\ * + +80 cells CONSTANT LOCALS-STACK-SIZE + +LOCALS-STACK-SIZE BUFFER: localsstackbuf + +localsstackbuf VALUE localsstack + + +: fc-local@ ( n -- val ) + cells localsstack swap - @ +; + +: fc-local-1-@ 1 fc-local@ ; +: fc-local-2-@ 2 fc-local@ ; +: fc-local-3-@ 3 fc-local@ ; +: fc-local-4-@ 4 fc-local@ ; +: fc-local-5-@ 5 fc-local@ ; +: fc-local-6-@ 6 fc-local@ ; +: fc-local-7-@ 7 fc-local@ ; +: fc-local-8-@ 8 fc-local@ ; + + +: fc-local! ( val n -- ) + cells localsstack swap - ! +; + +: fc-local-1-! 1 fc-local! ; +: fc-local-2-! 2 fc-local! ; +: fc-local-3-! 3 fc-local! ; +: fc-local-4-! 4 fc-local! ; +: fc-local-5-! 5 fc-local! ; +: fc-local-6-! 6 fc-local! ; +: fc-local-7-! 7 fc-local! ; +: fc-local-8-! 8 fc-local! ; + + +0 VALUE uses-locals? + +\ Create space for the current function on the locals stack. +\ Pre-initialized the n first locals with the n top-most data stack items. +\ Note: Each function can use up to 8 (initialized or uninitialized) locals. +: (fc-push-locals) ( ... n -- ) + \ cr ." pushing " dup . ." locals" cr + 8 cells localsstack + TO localsstack + localsstack localsstackbuf - + LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!" + ?dup IF + ( ... n ) 1 swap DO + i fc-local! \ Store pre-initialized locals + -1 +LOOP + THEN +; + +: fc-push-locals ( n -- ) + \ cr ." compiling push for " dup . ." locals" cr + uses-locals? ABORT" Definition pushes locals multiple times!" + true TO uses-locals? + ( n ) ['] literal execute + ['] (fc-push-locals) compile, +; + +: fc-push-0-locals 0 fc-push-locals ; +: fc-push-1-locals 1 fc-push-locals ; +: fc-push-2-locals 2 fc-push-locals ; +: fc-push-3-locals 3 fc-push-locals ; +: fc-push-4-locals 4 fc-push-locals ; +: fc-push-5-locals 5 fc-push-locals ; +: fc-push-6-locals 6 fc-push-locals ; +: fc-push-7-locals 7 fc-push-locals ; +: fc-push-8-locals 8 fc-push-locals ; + + +: fc-pop-locals ( -- ) + \ ." popping locals" cr + localsstack 8 cells - TO localsstack + localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!" +; + + +: fc-locals-exit + uses-locals? IF + \ ." compiling pop-locals for exit" cr + ['] fc-pop-locals compile, + THEN + ['] exit compile, +; + +: fc-locals-b(;) + uses-locals? IF + \ ." compiling pop-locals for b(;)" cr + ['] fc-pop-locals compile, + THEN + false TO uses-locals? + ['] b(;) execute +; + + +: fc-set-locals-tokens ( -- ) + ['] fc-push-0-locals 1 407 set-token + ['] fc-push-1-locals 1 408 set-token + ['] fc-push-2-locals 1 409 set-token + ['] fc-push-3-locals 1 40a set-token + ['] fc-push-4-locals 1 40b set-token + ['] fc-push-5-locals 1 40c set-token + ['] fc-push-6-locals 1 40d set-token + ['] fc-push-7-locals 1 40e set-token + ['] fc-push-8-locals 1 40f set-token + + ['] fc-local-1-@ 0 410 set-token + ['] fc-local-2-@ 0 411 set-token + ['] fc-local-3-@ 0 412 set-token + ['] fc-local-4-@ 0 413 set-token + ['] fc-local-5-@ 0 414 set-token + ['] fc-local-6-@ 0 415 set-token + ['] fc-local-7-@ 0 416 set-token + ['] fc-local-8-@ 0 417 set-token + + ['] fc-local-1-! 0 418 set-token + ['] fc-local-2-! 0 419 set-token + ['] fc-local-3-! 0 41a set-token + ['] fc-local-4-! 0 41b set-token + ['] fc-local-5-! 0 41c set-token + ['] fc-local-6-! 0 41d set-token + ['] fc-local-7-! 0 41e set-token + ['] fc-local-8-! 0 41f set-token + + ['] fc-locals-exit 1 33 set-token + ['] fc-locals-b(;) 1 c2 set-token +; +fc-set-locals-tokens diff --git a/src/roms/SLOF/slof/fs/fcode/tokens.fs b/src/roms/SLOF/slof/fs/fcode/tokens.fs new file mode 100644 index 0000000..3efc17e --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/tokens.fs @@ -0,0 +1,480 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: fc-abort ." FCode called abort: IP " get-ip . ( ." STACK: " .s ) depth dup 0< IF abort THEN . rdepth . cr abort ; +: fc-0 ." 0(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 0 ; +: fc-1 ." 1(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 1 ; + +: parse-1hex 1 hex-decode-unit ; + +\ Adjust functions for accessing MMIO registers. According to IEEE 1275, +\ a bus device can substitute bus-specific implementations of r*@ and r*! +\ for use by its children, e.g. with respect to byte-order. Since PCI is +\ little endian by default, we've got to use the little endian accessor +\ functions for the PCI bus (some FCODE programs are expecting this behavior). +: fc-set-pci-mmio-tokens ( -- ) + ['] rw@-le 0 232 set-token + ['] rw!-le 0 233 set-token + ['] rl@-le 0 234 set-token + ['] rl!-le 0 235 set-token + ['] rx@-le 0 22E set-token + ['] rx!-le 0 22F set-token +; + +\ Set normal MMIO access token behavior: +: fc-set-normal-mmio-tokens ( -- ) + ['] rw@ 0 232 set-token + ['] rw! 0 233 set-token + ['] rl@ 0 234 set-token + ['] rl! 0 235 set-token + ['] rx@ 0 22E set-token + ['] rx! 0 22F set-token +; + +: reset-token-table + FFF 0 DO ['] ferror 0 i set-token LOOP + ; + +reset-token-table + +' end0 0 00 set-token + +\ 01...0F beginning code of 2-byte FCode sequences + +' b(lit) 1 10 set-token + +' b(') 1 11 set-token +' b(") 1 12 set-token +' bbranch 1 13 set-token +' b?branch 1 14 set-token +' b(loop) 1 15 set-token +' b(+loop) 1 16 set-token +' b(do) 1 17 set-token +' b(?do) 1 18 set-token +' i 0 19 set-token +' j 0 1A set-token +' b(leave) 1 1B set-token +' b(of) 1 1C set-token +' execute 0 1D set-token +' + 0 1E set-token +' - 0 1F set-token +' * 0 20 set-token +' / 0 21 set-token +' mod 0 22 set-token +' and 0 23 set-token +' or 0 24 set-token +' xor 0 25 set-token +' invert 0 26 set-token +' lshift 0 27 set-token +' rshift 0 28 set-token +' >>a 0 29 set-token +' /mod 0 2A set-token +' u/mod 0 2B set-token +' negate 0 2C set-token +' abs 0 2D set-token +' min 0 2E set-token +' max 0 2F set-token +' >r 0 30 set-token +' r> 0 31 set-token +' r@ 0 32 set-token +' exit 0 33 set-token +' 0= 0 34 set-token +' 0<> 0 35 set-token +' 0< 0 36 set-token +' 0<= 0 37 set-token +' 0> 0 38 set-token +' 0>= 0 39 set-token +' < 0 3A set-token +' > 0 3B set-token +' = 0 3C set-token +' <> 0 3D set-token +' u> 0 3E set-token +' u<= 0 3F set-token +' u< 0 40 set-token +' u>= 0 41 set-token +' >= 0 42 set-token +' <= 0 43 set-token +' between 0 44 set-token +' within 0 45 set-token +' DROP 0 46 set-token +' DUP 0 47 set-token +' OVER 0 48 set-token +' SWAP 0 49 set-token +' ROT 0 4A set-token +' -ROT 0 4B set-token +' TUCK 0 4C set-token +' nip 0 4D set-token +' pick 0 4E set-token +' roll 0 4F set-token +' ?dup 0 50 set-token +' depth 0 51 set-token +' 2drop 0 52 set-token +' 2dup 0 53 set-token +' 2over 0 54 set-token +' 2swap 0 55 set-token +' 2rot 0 56 set-token +' 2/ 0 57 set-token +' u2/ 0 58 set-token +' 2* 0 59 set-token +' /c 0 5A set-token +' /w 0 5B set-token +' /l 0 5C set-token +' /n 0 5D set-token +' ca+ 0 5E set-token +' wa+ 0 5F set-token +' la+ 0 60 set-token +' na+ 0 61 set-token +' char+ 0 62 set-token +' wa1+ 0 63 set-token +' la1+ 0 64 set-token +' cell+ 0 65 set-token +' chars 0 66 set-token +' /w* 0 67 set-token +' /l* 0 68 set-token +' cells 0 69 set-token +' on 0 6A set-token +' off 0 6B set-token +' +! 0 6C set-token +' @ 0 6D set-token +' fc-l@ 0 6E set-token +' fc-w@ 0 6F set-token +' fc-<w@ 0 70 set-token +' fc-c@ 0 71 set-token +' ! 0 72 set-token +' fc-l! 0 73 set-token +' fc-w! 0 74 set-token +' fc-c! 0 75 set-token +' 2@ 0 76 set-token +' 2! 0 77 set-token +' fc-move 0 78 set-token +' fc-fill 0 79 set-token +' comp 0 7A set-token +' noop 0 7B set-token +' lwsplit 0 7C set-token +' wljoin 0 7D set-token +' lbsplit 0 7E set-token +' bljoin 0 7F set-token +' wbflip 0 80 set-token +' upc 0 81 set-token +' lcc 0 82 set-token +' pack 0 83 set-token +' count 0 84 set-token +' body> 0 85 set-token +' >body 0 86 set-token +' fcode-revision 0 87 set-token +' span 0 88 set-token +' unloop 0 89 set-token +' expect 0 8A set-token +' alloc-mem 0 8B set-token +' free-mem 0 8C set-token +' key? 0 8D set-token +' key 0 8E set-token +' emit 0 8F set-token +' type 0 90 set-token +' (cr 0 91 set-token +' cr 0 92 set-token +' #out 0 93 set-token +' #line 0 94 set-token +' hold 0 95 set-token +' <# 0 96 set-token +' u#> 0 97 set-token +' sign 0 98 set-token +' u# 0 99 set-token +' u#s 0 9A set-token +' u. 0 9B set-token +' u.r 0 9C set-token +' . 0 9D set-token +' .r 0 9E set-token +' .s 0 9F set-token +' base 0 A0 set-token +\ ' convert 0 A1 set-token \ historical, not supported +' $number 0 A2 set-token +' digit 0 A3 set-token +' -1 0 A4 set-token +' 0 0 A5 set-token +' 1 0 A6 set-token +' 2 0 A7 set-token +' 3 0 A8 set-token +' bl 0 A9 set-token +' bs 0 AA set-token +' bell 0 AB set-token +' bounds 0 AC set-token +' here 0 AD set-token +' aligned 0 AE set-token +' wbsplit 0 AF set-token +' bwjoin 0 B0 set-token +' b(<mark) 1 B1 set-token +' b(>resolve) 1 B2 set-token +\ ' set-token-table 0 B3 set-token \ historical, not supported +\ ' set-table 0 B4 set-token \ historical, not supported +' new-token 0 B5 set-token +' named-token 0 B6 set-token +' b(:) 1 B7 set-token +' b(value) 1 B8 set-token +' b(variable) 1 B9 set-token +' b(constant) 1 BA set-token +' b(create) 1 BB set-token +' b(defer) 1 BC set-token +' b(buffer:) 1 BD set-token +' b(field) 1 BE set-token +\ ' b(code) 0 BF set-token \ historical, not supported +' fc-instance 1 C0 set-token +\ ' ferror 0 C1 set-token \ Reserved +' b(;) 1 C2 set-token +' b(to) 1 C3 set-token +' b(case) 1 C4 set-token +' b(endcase) 1 C5 set-token +' b(endof) 1 C6 set-token +' # 0 C7 set-token +' #s 0 C8 set-token +' #> 0 C9 set-token +' external-token 0 CA set-token +' $find 0 CB set-token +' offset16 0 CC set-token +' evaluate 0 CD set-token +\ 0 CE reserved +\ 0 CF reserved +' c, 0 D0 set-token +' w, 0 D1 set-token +' l, 0 D2 set-token +' , 0 D3 set-token +' um* 0 D4 set-token +' um/mod 0 D5 set-token +\ 0 D6 reserved +\ 0 D7 reserved +' d+ 0 D8 set-token +' d- 0 D9 set-token +' get-token 0 DA set-token +' set-token 0 DB set-token +' state 0 DC set-token \ possibly broken +' compile, 0 DD set-token +' behavior 0 DE set-token + +\ Tokens 0xDF to 0xEF are reserved + +' start0 0 F0 set-token +' start1 0 F1 set-token +' start2 0 F2 set-token +' start4 0 F3 set-token + +\ Tokens 0xF4 to 0xFB are reserved + +' ferror 0 FC set-token +' version1 0 FD set-token + +\ ' 4-byte-id 0 FE set-token \ Historical, not supported +' end1 0 FF set-token + +\ 0 100 set-token \ reserved +' dma-alloc 0 101 set-token \ Obsolete +' my-address 0 102 set-token +' my-space 0 103 set-token +\ ' memmap 0 104 set-token \ Obsolete +' free-virtual 0 105 set-token +\ ' >physical 0 106 set-token \ Obsolete + +\ Tokens 0x107 to 0x10e are reserved + +' my-params 0 10f set-token \ Obsolete +' property 0 110 set-token +' encode-int 0 111 set-token +' encode+ 0 112 set-token +' encode-phys 0 113 set-token +' encode-string 0 114 set-token +' encode-bytes 0 115 set-token +' reg 0 116 set-token +' intr 0 117 set-token \ Obsolete +' driver 0 118 set-token \ Obsolete +' model 0 119 set-token +' device-type 0 11A set-token +' parse-2int 0 11B set-token +\ ' is-install 0 11C set-token \ Will be set by framebuffer code +\ ' is-remove 0 11D set-token \ Will be set by framebuffer code +\ ' is-selftest 0 11E set-token \ Will be set by framebuffer code +' new-device 0 11F set-token +' diagnostic-mode? 0 120 set-token +' display-status 0 121 set-token \ Maybe obsolete +' memory-test-suite 0 122 set-token +' group-code 0 123 set-token \ Obsolete +' mask 0 124 set-token +' get-msecs 0 125 set-token +' ms 0 126 set-token +' finish-device 0 127 set-token +' decode-phys 0 128 set-token +\ ' push-package 0 129 set-token \ TODO - from proposal 215 +\ ' pop-package 0 12A set-token \ TODO - from proposal 215 +' interpose 0 12B set-token \ Recommended practice: Interposition + +\ Tokens 0x12C to 0x12F are reserved + +' map-low 0 130 set-token +' sbus-intr>cpu 0 131 set-token \ Obsolete + +\ Tokens 0x132 to 0x14f are reserved + +\ The following tokens will be set by the framebuffer code: +\ ' #lines 0 150 set-token +\ ' #columns 0 151 set-token +\ ' line# 0 152 set-token +\ ' column# 0 153 set-token +\ ' inverse? 0 154 set-token +\ ' inverse-screen? 0 155 set-token +\ ' frame-buffer-busy 0 156 set-token \ Historical, not supported +\ ' draw-character 0 157 set-token +\ ' reset-screen 0 158 set-token +\ ' toggle-cursor 0 159 set-token +\ ' erase-screen 0 15A set-token +\ ' blink-screen 0 15B set-token +\ ' invert-screen 0 15C set-token +\ ' insert-characters 0 15D set-token +\ ' delete-characters 0 15E set-token +\ ' insert-lines 0 15F set-token +\ ' delete-lines 0 160 set-token +\ ' draw-logo 0 161 set-token +\ ' frame-buffer-adr 0 162 set-token +\ ' screen-height 0 163 set-token +\ ' screen-width 0 164 set-token +\ ' window-top 0 165 set-token +\ ' window-left 0 166 set-token +\ ' 0 167 set-token \ Reserved +\ ' foreground-color 0 168 set-token \ From 16-color recommended practice +\ ' background-color 0 169 set-token \ From 16-color recommended practice +\ ' default-font 0 16A set-token +\ ' set-font 0 16B set-token +\ ' char-height 0 16C set-token +\ ' char-width 0 16D set-token +\ ' >font 0 16E set-token +\ ' fontbytes 0 16F set-token + +\ Tokens 0x170 to 0x17C are obsolete fb1 functions +\ Tokens 0x17D to 0x17F are reserved + +\ The following tokens will be set by the framebuffer code, too: +\ ' fb8-draw-character 0 180 set-token +\ ' fb8-reset-screen 0 181 set-token +\ ' fb8-toggle-cursor 0 182 set-token +\ ' fb8-erase-screen 0 183 set-token +\ ' fb8-blink-screen 0 184 set-token +\ ' fb8-invert-screen 0 185 set-token +\ ' fb8-insert-characters 0 186 set-token +\ ' fb8-delete-characters 0 187 set-token +\ ' fb8-insert-lines 0 188 set-token +\ ' fb8-delete-lines 0 189 set-token +\ ' fb8-draw-logo 0 18A set-token +\ ' fb8-install 0 18B set-token + +\ Tokens 0x18C to 0x18F are reserved +\ Tokens 0x190 to 0x196 are obsolete VMEbus tokens +\ Tokens 0x197 to 0x19F are reserved + +\ ' return-buffer 0 1A0 set-token \ Historical, not supported +\ ' xmit-packet 0 1A1 set-token \ Historical, not supported +\ ' poll-packet 0 1A2 set-token \ Historical, not supported +\ 0 1A3 set-token \ reserved +' mac-address 0 1A4 set-token + +\ Tokens 0x1A5 to 0x200 are reserved + +' device-name 0 201 set-token +' my-args 0 202 set-token +' my-self 0 203 set-token +' find-package 0 204 set-token +' open-package 0 205 set-token +' close-package 0 206 set-token +' find-method 0 207 set-token +' call-package 0 208 set-token +' $call-parent 0 209 set-token +' my-parent 0 20A set-token +' ihandle>phandle 0 20B set-token +\ 0 20C set-token \ reserved +' my-unit 0 20D set-token +' $call-method 0 20E set-token +' $open-package 0 20F set-token +' processor-type 0 210 set-token \ Obsolete +' firmware-version 0 211 set-token \ Obsolete +' fcode-version 0 212 set-token \ Obsolete +\ ' alarm 0 213 set-token \ TODO +' (is-user-word) 0 214 set-token +' suspend-fcode 0 215 set-token +' fc-abort 0 216 set-token +' catch 0 217 set-token +' throw 0 218 set-token +\ ' user-abort 0 219 set-token \ TODO +' get-my-property 0 21A set-token +' decode-int 0 21B set-token +' decode-string 0 21C set-token +' get-inherited-property 0 21D set-token +' delete-property 0 21E set-token +' get-package-property 0 21F set-token +' cpeek 0 220 set-token +' wpeek 0 221 set-token +' lpeek 0 222 set-token +' cpoke 0 223 set-token +' wpoke 0 224 set-token +' lpoke 0 225 set-token +' lwflip 0 226 set-token +' lbflip 0 227 set-token +' lbflips 0 228 set-token +\ ' adr-mask 0 229 set-token \ Historical, not supported + +\ Tokens 0x22A to 0x22F are reserved + +' rb@ 0 230 set-token +' rb! 0 231 set-token +fc-set-normal-mmio-tokens \ Set rw@, rw!, rl@, rl!, rx@ and rx! + +' wbflips 0 236 set-token +' lwflips 0 237 set-token +\ ' probe 0 238 set-token \ Obsolete +\ ' probe-virtual 0 239 set-token \ Obsolete +\ 0 23A reserved +' child 0 23B set-token +' peer 0 23C set-token +' next-property 0 23D set-token +' byte-load 0 23E set-token +' set-args 0 23F set-token +' left-parse-string 0 240 set-token + +\ 64-bit extension tokens: +' bxjoin 0 241 set-token +' fc-<l@ 0 242 set-token +' lxjoin 0 243 set-token +' wxjoin 0 244 set-token +' x, 0 245 set-token +' fc-x@ 0 246 set-token +' fc-x! 0 247 set-token +' /x 0 248 set-token +' /x* 0 249 set-token +' xa+ 0 24A set-token +' xa1+ 0 24B set-token +' xbflip 0 24C set-token +' xbflips 0 24D set-token +' xbsplit 0 24E set-token +' xlflip 0 24F set-token +' xlflips 0 250 set-token +' xlsplit 0 251 set-token +' xwflip 0 252 set-token +' xwflips 0 253 set-token +' xwsplit 0 254 set-token + +\ 0 255 RESERVED FCODES +\ ... +\ 0 5FF RESERVED FCODES + +\ 0 600 VENDOR FCODES +\ ... +\ 0 7FF VENDOR FCODES + +\ 0 800 LOCAL FCODES +\ ... +\ 0 FFF LOCAL FCODES + diff --git a/src/roms/SLOF/slof/fs/find-hash.fs b/src/roms/SLOF/slof/fs/find-hash.fs new file mode 100644 index 0000000..a40ccbd --- /dev/null +++ b/src/roms/SLOF/slof/fs/find-hash.fs @@ -0,0 +1,77 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +#ifdef HASH_DEBUG +0 value from-hash +0 value not-from-hash +0 value hash-collisions +#endif + +clean-hash + +: hash-find ( str len head -- 0 | link ) + >r 2dup 2dup hash ( str len str len hash R: head ) + dup >r @ dup ( str len str len *hash *hash R: head hash ) + IF ( str len str len *hash R: head hash ) + link>name name>string string=ci ( str len true|false R: head hash ) + dup 0= + IF +#ifdef HASH_DEBUG + hash-collisions 1+ + to hash-collisions +#endif + THEN + ELSE + nip nip ( str len 0 R: head hash ) + THEN + IF \ hash found + 2drop r> @ r> drop ( *hash R: ) +#ifdef HASH_DEBUG + from-hash 1+ to from-hash +#endif + exit + THEN \ hash not found + r> r> swap >r ((find)) ( str len head R: hash=0 ) + dup + IF +#ifdef HASH_DEBUG + not-from-hash 1+ + to not-from-hash +#endif + dup r> ! ( link R: ) + ELSE + r> drop ( 0 R: ) + THEN +; + +: hash-reveal hash off ; + +' hash-reveal to (reveal) +' hash-find to (find) + +#ifdef HASH_DEBUG +\ print out all entries in the hash table +: dump-hash-table ( -- ) + cr + hash-table hash-size 0 DO + dup @ dup 0<> IF + over . s" : " type link>name name>string type cr + ELSE + drop + THEN + cell+ + LOOP drop + s" hash-collisions: " type hash-collisions . cr + s" from-hash: " type from-hash . cr + s" not-from-hash: " type not-from-hash . cr +; +#endif diff --git a/src/roms/SLOF/slof/fs/generic-disk.fs b/src/roms/SLOF/slof/fs/generic-disk.fs new file mode 100644 index 0000000..0543c89 --- /dev/null +++ b/src/roms/SLOF/slof/fs/generic-disk.fs @@ -0,0 +1,68 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Generic disk support + +\ Input: +\ name of device ( e.g. "disk", "cdrom", ... ) +\ dev# + +\ Needs from parent in device tree: +\ dev-read-blocks ( addr block# #blocks phys.lo ... phys.hi -- #read ) +\ block-size +\ max-transfer + +\ Provides: +\ open ( -- okay? ) +\ close ( -- ) +\ read ( addr len -- actual ) +\ seek ( pos.lo pos.hi -- status ) +\ read-blocks ( addr block# #blocks -- #read ) +\ Uses: +\ disk-label package interpose for partition and file systems support +\ deblocker package for byte read support + +( str len phys.lo ... phys.hi -- ) +new-device set-unit ( str len ) + 2dup device-name + s" 0 pci-alias-" 2swap $cat evaluate + s" block" device-type + +\ Requiered interface for deblocker + + s" block-size" $call-parent CONSTANT block-size + s" max-transfer" $call-parent CONSTANT max-transfer + +: read-blocks ( addr block# #blocks -- #read ) + my-unit s" dev-read-blocks" $call-parent +; + +INSTANCE VARIABLE deblocker + +: open ( -- okay? ) + 0 0 s" deblocker" $open-package dup deblocker ! dup IF + s" disk-label" find-package IF + my-args rot interpose + THEN + THEN 0<> ; + +: close ( -- ) + deblocker @ close-package ; + +: seek ( pos.lo pos.hi -- status ) + s" seek" deblocker @ $call-method ; + +: read ( addr len -- actual ) + s" read" deblocker @ $call-method ; + +finish-device diff --git a/src/roms/SLOF/slof/fs/graphics.fs b/src/roms/SLOF/slof/fs/graphics.fs new file mode 100644 index 0000000..7d5d930 --- /dev/null +++ b/src/roms/SLOF/slof/fs/graphics.fs @@ -0,0 +1,87 @@ +\ ***************************************************************************** +\ * Copyright (c) 2015 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Provide some of the functions that are defined in the +\ "OF Recommended Practice: 8bit Graphics Extension" document + +: draw-rectangle ( adr x y w h -- ) + frame-buffer-adr 0= IF 4drop drop EXIT THEN + 0 ?DO + 4dup drop ( adr x y w adr x y ) + \ calculate offset into framebuffer: ((y + i) * width + x) * depth + i + screen-width * + screen-depth * ( adr x y w adr offs ) + frame-buffer-adr + ( adr x y w adr fb_adr ) + over 3 pick screen-depth * i * + ( adr x y w adr fb_adr src ) + swap 3 pick screen-depth * ( adr x y w adr src fb_adr len ) + rmove \ copy line ( adr x y w adr ) + drop ( adr x y w ) + LOOP + 4drop +; + +: fill-rectangle ( col x y w h -- ) + frame-buffer-adr 0= IF 4drop drop EXIT THEN + 0 ?DO + 4dup drop ( col x y w col x y ) + \ calculate offset into framebuffer: ((y + i) * width + x) * depth + i + screen-width * + screen-depth * ( col x y w col offs ) + frame-buffer-adr + ( col x y w col adr ) + 2 pick screen-depth * 2 pick ( col x y w col adr len col ) + rfill \ draw line ( col x y w col ) + drop ( col x y w ) + LOOP + 4drop +; + +: read-rectangle ( adr x y w h -- ) + frame-buffer-adr 0= IF 4drop drop EXIT THEN + 0 ?DO + 4dup drop ( adr x y w adr x y ) + \ calculate offset into framebuffer: ((y + i) * width + x) * depth + i + screen-width * + screen-depth * ( adr x y w adr offs ) + frame-buffer-adr + ( adr x y w adr fb_adr ) + over 3 pick screen-depth * i * + ( adr x y w adr fb_adr dst ) + 3 pick ( adr x y w adr fb_adr dst w ) + rmove \ copy line ( adr x y w adr ) + drop ( adr x y w ) + LOOP + 4drop +; + +: dimensions ( -- width height ) + screen-width screen-height +; + +\ Initialize a default palette (not a standard command, but useful anyway) +: init-default-palette + \ Grayscale ramp for upper colors + 100 10 DO + i i i i color! + LOOP + \ Standard colors from "16-color Text Extension" specification + 00 00 00 0 color! + 00 00 aa 1 color! + 00 aa 00 2 color! + 00 aa aa 3 color! + aa 00 00 4 color! + aa 00 aa 5 color! + aa 55 00 6 color! + aa aa aa 7 color! + 55 55 55 8 color! + 55 55 ff 9 color! + 55 ff 55 a color! + 55 ff ff b color! + ff 55 55 c color! + ff 55 ff d color! + ff ff 55 e color! + ff ff ff f color! +; diff --git a/src/roms/SLOF/slof/fs/history.fs b/src/roms/SLOF/slof/fs/history.fs new file mode 100644 index 0000000..2c2c70f --- /dev/null +++ b/src/roms/SLOF/slof/fs/history.fs @@ -0,0 +1,107 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Create debug section in NVRAM +: debug-init-nvram ( -- ) + nvram-partition-type-debug get-nvram-partition IF + cr ." Could not find debug partition in NVRAM - " + nvram-partition-type-debug s" debug" d# 1024 new-nvram-partition + ABORT" Failed to create DEBUG NVRAM partition" + 2dup erase-nvram-partition drop + ." created." cr + THEN + s" debug-nvram-partition" $2constant +; + +debug-init-nvram + +: debug-add-env ( "name" "value" -- ) debug-nvram-partition 2rot 2rot internal-add-env drop ; +: debug-set-env ( "name" "value" -- ) debug-nvram-partition 2rot 2rot internal-set-env drop ; +: debug-get-env ( "name" -- "value" TRUE | FALSE) debug-nvram-partition 2swap internal-get-env ; + +: debug-get-history-enabled ( -- n ) s" history-enabled?" debug-get-env IF $number IF 0 THEN ELSE 0 THEN ; +: debug-set-history-enabled ( n -- ) (.) s" history-enabled?" 2swap debug-set-env ; + + +debug-get-history-enabled constant nvram-history? + +nvram-history? [IF] + +: history-init-nvram ( -- ) + nvram-partition-type-history get-nvram-partition IF + cr ." Could not find history partition in NVRAM - " + nvram-partition-type-history s" history" d# 2048 new-nvram-partition + ABORT" Failed to create SMS NVRAM partition" + 2dup erase-nvram-partition drop + ." created" cr + THEN + s" history-nvram-partition" $2constant +; + +history-init-nvram + +0 value (history-len) +0 value (history-adr) + +: (history-load-one) ( str len -- len ) + \ 2dup ." loading " type cr + to (history-len) to (history-adr) + /his (history-len) + alloc-mem ( his ) + his-tail 0= IF dup to his-tail THEN + his-head over his>next ! to his-head + his-head his>next @ his>prev his-head swap ! + (history-len) his-head his>len ! + (history-adr) his-head his>buf (history-len) move + (history-len) 1+ +; + +: history-load ( -- ) + history-nvram-partition drop BEGIN dup WHILE + dup rzcount ( part str len ) + dup IF + (history-load-one) + + ELSE + 3drop 0 + THEN + REPEAT + drop +; + +: (history-store-one) ( pos len saddr slen -- FALSE | npos nlen TRUE ) + dup 3 pick < IF \ enough space + dup >r rot >r + \ 2dup ." storing " type cr + bounds DO dup i c@ swap nvram-c! 1+ LOOP + dup 0 swap nvram-c! 1+ + r> r> - 1- true + ELSE + 2drop false + THEN +; + +: history-store ( -- ) + history-nvram-partition erase-nvram-partition drop + history-nvram-partition his-tail BEGIN dup WHILE + dup his>buf over his>len @ + ( position len link saddr slen ) + rot >r (history-store-one) r> + swap IF his>prev @ ELSE drop 0 THEN + REPEAT + 2drop drop +; + +\ redefine "end of SLOF" words to safe history +: reset-all history-store reset-all ; +: reboot history-store reboot ; +: boot history-store boot ; + +[THEN] diff --git a/src/roms/SLOF/slof/fs/ide.fs b/src/roms/SLOF/slof/fs/ide.fs new file mode 100644 index 0000000..d6f16ed --- /dev/null +++ b/src/roms/SLOF/slof/fs/ide.fs @@ -0,0 +1,612 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ +\ 26.06.2007 added: two devices (Master/Slave) per channel + +1 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + +: decode-unit 1 hex-decode-unit ; +: encode-unit 1 hex-encode-unit ; + +0 VALUE >ata \ base address for command-block +0 VALUE >ata1 \ base address for control block + +true VALUE no-timeout \ flag that no timeout occurred + +0c CONSTANT #cdb-bytes \ command descriptor block (12 bytes) +800 CONSTANT atapi-size +200 CONSTANT ata-size + +\ ***************************** +\ Some register access helpers. +\ ***************************** +: ata-ctrl! 2 >ata1 + io-c! ; \ device control reg +: ata-astat@ 2 >ata1 + io-c@ ; \ read alternate status + +: ata-data@ 0 >ata + io-w@ ; \ data reg +: ata-data! 0 >ata + io-w! ; \ data reg +: ata-err@ 1 >ata + io-c@ ; \ error reg +: ata-feat! 1 >ata + io-c! ; \ feature reg +: ata-cnt@ 2 >ata + io-c@ ; \ sector count reg +: ata-cnt! 2 >ata + io-c! ; \ sector count reg +: ata-lbal! 3 >ata + io-c! ; \ lba low reg +: ata-lbal@ 3 >ata + io-c@ ; \ lba low reg +: ata-lbam! 4 >ata + io-c! ; \ lba mid reg +: ata-lbam@ 4 >ata + io-c@ ; \ lba mid reg +: ata-lbah! 5 >ata + io-c! ; \ lba high reg +: ata-lbah@ 5 >ata + io-c@ ; \ lba high reg +: ata-dev! 6 >ata + io-c! ; \ device reg +: ata-dev@ 6 >ata + io-c@ ; \ device reg +: ata-cmd! 7 >ata + io-c! ; \ command reg +: ata-stat@ 7 >ata + io-c@ ; \ status reg + +\ ********************************************************************** +\ ATA / ATAPI Commands specifications: +\ - AT Attachment 8 - ATA/ATAPI Command Set (ATA8-ACS) +\ - ATA Packet Interface for CD-ROMs SFF-8020i +\ - ATA/ATAPI Host Adapters Standard (T13/1510D) +\ ********************************************************************** +00 CONSTANT cmd#nop \ ATA and ATAPI +08 CONSTANT cmd#device-reset \ ATAPI only (mandatory) +20 CONSTANT cmd#read-sector \ ATA and ATAPI +90 CONSTANT cmd#execute-device-diagnostic \ ATA and ATAPI +a0 CONSTANT cmd#packet \ ATAPI only (mandatory) +a1 CONSTANT cmd#identify-packet-device \ ATAPI only (mandatory) +ec CONSTANT cmd#identify-device \ ATA and ATAPI + +\ ***************************** +\ Setup Regs for ATA: +\ BAR 0 & 1 : Device 0 +\ BAR 2 & 3 : Device 1 +\ ***************************** +: set-regs ( n -- ) + dup + 01 and \ only Chan 0 or Chan 1 allowed + 3 lshift dup 10 + config-l@ -4 and to >ata + 14 + config-l@ -4 and to >ata1 + 02 ata-ctrl! \ disable interrupts + 02 and + IF + 10 + ELSE + 00 + THEN + ata-dev! +; + +ata-size VALUE block-size +80000 VALUE max-transfer \ Arbitrary, really + +CREATE sector d# 512 allot +CREATE packet-cdb #cdb-bytes allot +CREATE return-buffer atapi-size allot + +scsi-open \ add scsi functions + +\ ******************************** +\ show all ATAPI-registers +\ data-register not read in order +\ to not influence PIO mode +\ ******************************** +: show-regs + cr + cr ." alt. Status: " ata-astat@ . + cr ." Status : " ata-stat@ . + cr ." Device : " ata-dev@ . + cr ." Error-Reg : " ata-err@ . + cr ." Sect-Count : " ata-cnt@ . + cr ." LBA-Low : " ata-lbal@ . + cr ." LBA-Med : " ata-lbam@ . + cr ." LBA-High : " ata-lbah@ . +; + +\ *************************************************** +\ reads ATAPI-Status and displays it if check-bit set +\ *************************************************** +: status-check ( -- ) + ata-stat@ + dup + 01 and \ is 'check' flag set ? + IF + cr + ." - ATAPI-Status: " . + ata-err@ \ retrieve sense code + dup + 60 = \ sense code = 6 ? + IF + ." ( media changed or reset )" \ 'unit attention' + drop \ drop err-reg content + ELSE + dup + ." (Err : " . \ show err-reg content + space + rshift 4 .sense-text \ show text string + 29 emit + THEN + cr + ELSE + drop \ remove unused status + THEN +; + +\ ************************************* +\ Wait for interface ready condition +\ Bit 7 of Status-Register is busy flag +\ new version with abort after 5 sec. +\ ************************************* +: wait-for-ready + get-msecs \ start timer + BEGIN + ata-stat@ 80 and 0<> \ busy flag still set ? + no-timeout and + WHILE \ yes + dup get-msecs swap + - \ calculate timer difference + FFFF AND \ reduce to 65.5 seconds + d# 5000 > \ difference > 5 seconds ? + IF + false to no-timeout + THEN + REPEAT + drop +; + +\ ************************************* +\ wait for specific status bits +\ new version with abort after 5 sec. +\ ************************************* +: wait-for-status ( val mask -- ) + get-msecs \ initial timer value (start) + >r + BEGIN + 2dup \ val mask + ata-stat@ and <> \ expected status ? + no-timeout and \ and no timeout ? + WHILE + get-msecs r@ - \ calculate timer difference + FFFF AND \ mask-off overflow bits + d# 5000 > \ 5 seconds exceeded ? + IF + false to no-timeout \ set global flag + THEN + REPEAT + r> \ clean return stack + 3drop +; + +\ ********************************* +\ remove extra spaces from string end +\ ********************************* +: cut-string ( saddr nul -- ) + swap + over + + swap + 1 rshift \ bytecount -> wordcount + 0 do + /w - + dup ( addr -- addr addr ) + w@ ( addr addr -- addr nuw ) + dup ( addr nuw -- addr nuw nuw ) + 2020 = + IF + drop + 0 + ELSE + LEAVE + THEN + over + w! + LOOP + drop + drop +; + +\ **************************************************** +\ prints model-string received by identify device +\ **************************************************** +: show-model ( dev# chan# -- ) + 2dup + ." CH " . \ channel 0 / 1 + 0= IF ." / MA" \ Master / Slave + ELSE ." / SL" + THEN + swap + 2 * + ." (@" . ." ) : " \ device number + sector 1 + + c@ + 80 AND 0= + IF + ." ATA-Drive " + ELSE + ." ATAPI-Drive " + THEN + + 22 emit \ start string display with " + sector d# 54 + \ string starts 54 bytes from buffer start + dup + d# 40 \ and is 40 chars long + cut-string \ remove all trailing spaces + + BEGIN + dup + w@ + wbflip + wbsplit + dup 0<> \ first char + IF + emit + dup 0<> \ second char + IF + emit + wa1+ \ increment address for next + false + ELSE \ second char = EndOfString + drop + true + THEN + ELSE \ first char = EndOfString + drop + drop + true + THEN + UNTIL \ end of string detected + drop + 22 emit \ end string display + + sector c@ \ get lower byte of first doublet + 80 AND \ check bit 7 + IF + ." (removable media)" + THEN + + sector 1 + + c@ + 80 AND 0= IF \ is this an ATA drive ? + sector d# 120 + \ get word 60 + 61 + rl@-le \ read 32-bit as little endian value + d# 512 \ standard ATA block-size + swap + .capacity-text ( block-size #blocks -- ) + THEN + + sector d# 98 + \ goto word 49 + w@ + wbflip + 200 and 0= IF cr ." ** LBA is not supported " THEN + + sector c@ \ get lower byte of first doublet + 03 AND 01 = \ we use 12-byte packet commands (=00b) + IF + cr ." packet size = 16 ** not supported ! **" + THEN + no-timeout not \ any timeout occurred so far ? + IF + cr ." ** timeout **" + THEN +; + +\ **************************** +\ ATA functions +\ **************************** +: pio-sector ( addr -- ) 100 0 DO ata-data@ + over w! wa1+ LOOP drop ; +: pio-sector ( addr -- ) + wait-for-ready pio-sector ; +: pio-sectors ( n addr -- ) swap 0 ?DO dup pio-sector 200 + LOOP drop ; + +: lba! lbsplit + 0f and 40 or \ always set LBA-mode + LBA (27..24) + ata-dev@ 10 and or \ add current device-bit (DEV) + ata-dev! \ set LBA (27..24) + ata-lbah! \ set LBA (23..16) + ata-lbam! \ set LBA (15..8) + ata-lbal! \ set LBA (7..0) +; + +: read-sectors ( lba count addr -- ) + >r dup >r ata-cnt! lba! 20 ata-cmd! r> r> pio-sectors ; + +: read-sectors ( lba count addr dev-nr -- ) + set-regs ( lba count addr ) \ Set ata regs + BEGIN >r dup 100 > WHILE + over 100 r@ read-sectors + >r 100 + r> 100 - r> 20000 + REPEAT + r> read-sectors +; + +: ata-read-blocks ( addr block# #blocks dev# -- #read ) + swap dup >r swap >r rot r> ( addr block# #blocks dev # R: #blocks ) + read-sectors r> ( R: #read ) +; + +\ ******************************* +\ ATAPI functions +\ preset LBA register with maximum +\ allowed block-size (16-bits) +\ ******************************* +: set-lba ( block-length -- ) + lbsplit ( quad -- b1.lo b2 b3 b4.hi ) + drop \ skip upper two bytes + drop + ata-lbah! + ata-lbam! +; + +\ ******************************************* +\ gets byte-count and reads a block of words +\ from data-register to a buffer +\ ******************************************* +: read-pio-block ( buff-addr -- buff-addr-new ) + ata-lbah@ 8 lshift \ get block length High + ata-lbam@ or \ get block length Low + 1 rshift \ bcount -> wcount + dup + 0> IF \ any data to transfer? + 0 DO \ words to read + dup \ buffer-address + ata-data@ swap w! \ write 16-bits + wa1+ \ address of next entry + LOOP + ELSE + drop ( buff-addr wcount -- buff-addr ) + THEN + wait-for-ready +; + +\ ******************************************** +\ ATAPI support +\ Send a command block (12 bytes) in PIO mode +\ read data if requested +\ ******************************************** +: send-atapi-packet ( req-buffer -- ) + >r ( R: req-buffer ) + atapi-size set-lba \ set regs to length limit + 00 ata-feat! + cmd#packet ata-cmd! \ A0 = ATAPI packet command + 48 C8 wait-for-status ( val mask -- ) \ BSY:0 DRDY:1 DRQ:1 + 6 0 do + packet-cdb i 2 * + \ transfer command block (12 bytes) + w@ + ata-data! \ 6 doublets PIO transfer to device + loop \ copy packet to data-reg + status-check ( -- ) \ status err bit set ? -> display + wait-for-ready ( -- ) \ busy released ? + BEGIN + ata-stat@ 08 and 08 = WHILE \ Data-Request-Bit set ? + r> \ get last target buffer address + read-pio-block \ only if from device requested + >r \ start of next block + REPEAT + r> \ original value + drop \ return clean +; + +: atapi-packet-io ( -- ) + return-buffer atapi-size erase \ clear return buffer + return-buffer send-atapi-packet \ send 'packet-cdb' , get 'return-buffer' +; + + + +\ ******************************** +\ ATAPI packet commands +\ ******************************** + +\ Methods to access atapi disk + +: atapi-test ( -- true|false ) + packet-cdb scsi-build-test-unit-ready \ command-code: 00 + atapi-packet-io ( ) \ send CDB, get return-buffer + ata-stat@ 1 and IF false ELSE true THEN +; + +: atapi-sense ( -- ascq asc sense-key ) + d# 252 packet-cdb scsi-build-request-sense ( alloc-len cdb -- ) + atapi-packet-io ( ) \ send CDB, get return-buffer + return-buffer scsi-get-sense-data ( cdb-addr -- ascq asc sense-key ) +; + +: atapi-read-blocks ( address block# #blocks dev# -- #read-blocks ) + set-regs ( address block# #blocks ) + dup >r ( address block# #blocks ) + packet-cdb scsi-build-read-10 ( address block# #blocks cdb -- ) + send-atapi-packet ( address -- ) + r> \ return requested number of blocks +; + +\ *************************************** +\ read capacity of drive medium +\ use SCSI-Support Package +\ *************************************** +: atapi-read-capacity ( -- ) + packet-cdb scsi-build-read-cap-10 \ fill block with command + atapi-packet-io ( ) \ send CDB, get return-buffer + return-buffer scsi-get-capacity-10 ( cdb -- block-size #blocks ) + .capacity-text ( block-size #blocks -- ) + status-check ( -- ) +; + +\ *************************************** +\ read capacity of drive medium +\ use SCSI-Support Package +\ *************************************** +: atapi-read-capacity-ext ( -- ) + packet-cdb scsi-build-read-cap-16 \ fill block with command + atapi-packet-io ( ) \ send CDB, get return-buffer + return-buffer scsi-get-capacity-16 ( cdb -- block-size #blocks ) + .capacity-text ( block-size #blocks -- ) + status-check ( -- ) +; + + +\ *********************************************** +\ wait until media in drive is ready ( max 5 sec) +\ *********************************************** +: wait-for-media-ready ( -- true|false ) + get-msecs \ initial timer value (start) + >r + BEGIN + atapi-test \ unit ready? false if not + not + no-timeout and + WHILE + atapi-sense ( -- ascq asc sense-key ) + 02 = \ sense key 2 = media error + IF \ check add. sense code + 3A = \ asc: device not ready ? + IF + false to no-timeout + ." empty (" . 29 emit \ show asc qualifier + ELSE + drop \ discard asc qualifier + THEN \ medium not present, abort waiting + ELSE + drop \ discard asc + drop \ discard ascq + THEN + get-msecs r@ - \ calculate timer difference + FFFF AND \ mask-off overflow bits + d# 5000 > \ 5 seconds exceeded ? + IF + false to no-timeout \ set global flag + THEN + REPEAT + r> + drop + no-timeout +; + +\ ****************************************************** +\ Method pointer for read-blocks methods +\ controller implements 2 channels (primary / secondary) +\ for 2 devices each (master / slasve) +\ ****************************************************** +\ 2 channels (primary/secondary) per controller +2 CONSTANT #chan + +\ 2 devices (master/slave) per channel +2 CONSTANT #dev + +\ results in a total of devices +\ connected to a controller with +\ two separate channels (4) +: #totaldev #dev #chan * ; + +CREATE read-blocks-xt #totaldev cells allot read-blocks-xt #totaldev cells erase + +\ Execute read-blocks of device +: dev-read-blocks ( address block# #blocks dev# -- #read-blocks ) + dup cells read-blocks-xt + @ execute +; + +\ ********************************************************** +\ Read device type +\ Signature ATAPI ATA +\ --------------------------------------------- +\ Sector Count 01h 01h +\ Sector Number 01h 01h +\ Cylinder Low 14h 00h +\ Cylinder High EBh 00h +\ Device/Head 00h or 10h 00h or 01h +\ see also ATA/ATAPI errata at: +\ http://suif.stanford.edu/~csapuntz/blackmagic.html +\ ********************************************************** +: read-ident ( -- true|false ) + false + 00 ata-lbal! \ clear previous signature + 00 ata-lbam! + 00 ata-lbah! + cmd#identify-device ata-cmd! wait-for-ready \ first try ATA, ATAPI aborts command + ata-stat@ CF and 48 = + IF + drop true \ cmd accepted, this is a ATA + d# 512 set-lba \ set LBA to sector-length + ELSE \ ATAPI sends signature instead + ata-lbam@ 14 = IF \ cylinder low = 14 ? + ata-lbah@ EB = IF \ cylinder high = EB ? + cmd#device-reset ata-cmd! wait-for-ready \ only supported by ATAPI + cmd#identify-packet-device ata-cmd! wait-for-ready \ first try ata + ata-stat@ CF and 48 = IF + drop true \ replace flag + THEN + THEN + THEN + THEN + dup IF + ata-stat@ 8 AND IF \ data requested (as expected) ? + sector read-pio-block + drop \ discard address end + ELSE + drop false + THEN + THEN + + no-timeout not IF \ check without any timeout ? + drop + false \ no, detection discarded + THEN +; + +scsi-close \ remove scsi commands from word list + + +\ ************************************************* +\ Init controller ( chan 0 and 1 ) +\ device 0 (= master) and device 1 ( = slave) +\ #dev #chan Dev-ID +\ ---------------------- +\ 0 0 0 Master of Channel 0 +\ 0 1 1 Master of Channel 1 +\ 1 0 2 Slave of Channel 0 +\ 1 1 3 Slave of Channel 1 +\ ************************************************* +: find-disks ( -- ) + #chan 0 DO \ check 2 channels (primary & secondary) + #dev 0 DO \ check 2 devices per channel (master / slave) + i 2 * j + + set-regs \ set base address and dev-register for register access + ata-stat@ 7f and 7f <> \ Check, if device is connected + IF + true to no-timeout \ preset timeout-flag + read-ident ( -- true|false ) + IF + i j show-model \ print manufacturer + device string + sector 1+ c@ C0 and 80 = \ Check for ata or atapi + IF + wait-for-media-ready \ wait up to 5 sec if not ready + no-timeout and + IF + atapi-read-capacity + atapi-size to block-size \ ATAPI: 2048 bytes + 80000 to max-transfer + ['] atapi-read-blocks i 2 * j + cells read-blocks-xt + ! + s" cdrom" strdup i 2 * j + s" generic-disk.fs" included + ELSE + ." -" \ show hint for not registered + THEN + ELSE + ata-size to block-size \ ATA: 512 bytes + 80000 to max-transfer + ['] ata-read-blocks i 2 * j + cells read-blocks-xt + ! + s" disk" strdup i 2 * j + s" generic-disk.fs" included + THEN + cr + THEN + THEN + i 2 * j + 200 + cp + LOOP + LOOP +; + +find-disks + diff --git a/src/roms/SLOF/slof/fs/instance.fs b/src/roms/SLOF/slof/fs/instance.fs new file mode 100644 index 0000000..9e5c921 --- /dev/null +++ b/src/roms/SLOF/slof/fs/instance.fs @@ -0,0 +1,193 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Support for device node instances. + +0 VALUE my-self + +400 CONSTANT max-instance-size + +STRUCT + /n FIELD instance>node + /n FIELD instance>parent + /n FIELD instance>args + /n FIELD instance>args-len + /n FIELD instance>size + /n FIELD instance>#units + /n FIELD instance>unit1 \ For instance-specific "my-unit" + /n FIELD instance>unit2 + /n FIELD instance>unit3 + /n FIELD instance>unit4 +CONSTANT /instance-header + +: >instance ( offset -- myself+offset ) + my-self 0= ABORT" No instance!" + dup my-self instance>size @ >= ABORT" Instance access out of bounds!" + my-self + +; + +: (create-instance-var) ( initial-value -- ) + get-node + dup node>instance-size @ cell+ max-instance-size + >= ABORT" Instance is bigger than max-instance-size!" + dup node>instance-template @ ( iv phandle tmp-ih ) + swap node>instance-size dup @ ( iv tmp-ih *instance-size instance-size ) + dup , \ compile current instance ptr + swap 1 cells swap +! ( iv tmp-ih instance-size ) + + ! +; + +: create-instance-var ( "name" initial-value -- ) + CREATE (create-instance-var) PREVIOUS +; + +: (create-instance-buf) ( buffersize -- ) + aligned \ align size to multiples of cells + dup get-node node>instance-size @ + ( buffersize' newinstancesize ) + max-instance-size > ABORT" Instance is bigger than max-instance-size!" + get-node node>instance-template @ get-node node>instance-size @ + + over erase \ clear according to IEEE 1275 + get-node node>instance-size @ ( buffersize' old-instance-size ) + dup , \ compile current instance ptr + + get-node node>instance-size ! \ store new size +; + +: create-instance-buf ( "name" buffersize -- ) + CREATE (create-instance-buf) PREVIOUS +; + +VOCABULARY instance-words ALSO instance-words DEFINITIONS + +: VARIABLE 0 create-instance-var DOES> [ here ] @ >instance ; +: VALUE create-instance-var DOES> [ here ] @ >instance @ ; +: DEFER 0 create-instance-var DOES> [ here ] @ >instance @ execute ; +: BUFFER: create-instance-buf DOES> [ here ] @ >instance ; + +PREVIOUS DEFINITIONS + +\ Save XTs of the above instance-words (put on the stack with "[ here ]") +CONSTANT <instancebuffer> +CONSTANT <instancedefer> +CONSTANT <instancevalue> +CONSTANT <instancevariable> + +\ check whether a value or a defer word is an +\ instance word: It must be a CREATE word and +\ the DOES> part must do >instance as first thing + +: (instance?) ( xt -- xt true|false ) + dup @ <create> = IF + dup cell+ @ cell+ @ ['] >instance = + ELSE + false + THEN +; + +\ This word does instance values in compile mode. +\ It corresponds to DOTO from engine.in +: (doito) ( value R:*CFA -- ) + r> cell+ dup >r + @ cell+ cell+ @ >instance ! +; +' (doito) CONSTANT <(doito)> + +: to ( value wordname<> -- ) + ' (instance?) + state @ IF + \ compile mode handling normal or instance value + IF ['] (doito) ELSE ['] DOTO THEN + , , EXIT + THEN + IF + cell+ cell+ @ >instance ! \ interp mode instance value + ELSE + cell+ ! \ interp mode normal value + THEN +; IMMEDIATE + +: behavior ( defer-xt -- contents-xt ) + dup cell+ @ <instancedefer> = IF \ Is defer-xt an INSTANCE DEFER ? + 2 cells + @ >instance @ + ELSE + behavior + THEN +; + +: INSTANCE ALSO instance-words ; + +: my-parent my-self instance>parent @ ; +: my-args my-self instance>args 2@ swap ; + +\ copy args from original instance to new created +: set-my-args ( old-addr len -- ) + dup IF \ IF len > 0 ( old-addr len ) + dup alloc-mem \ | allocate space for new args ( old-addr len new-addr ) + 2dup my-self instance>args 2! \ | write into instance struct ( old-addr len new-addr ) + swap move \ | and copy the args ( ) + ELSE \ ELSE ( old-addr len ) + my-self instance>args 2! \ | set new args to zero, too ( ) + THEN \ FI +; + +\ Current node has already been set, when this is called. +: create-instance-data ( -- instance ) + get-node dup node>instance-template @ ( phandle instance-template ) + swap node>instance-size @ ( instance-template instance-size ) + dup >r + dup alloc-mem dup >r swap move r> ( instance ) + dup instance>size r> swap ! \ Store size for destroy-instance + dup instance>#units 0 swap ! \ Use node unit by default +; +: create-instance ( -- ) + my-self create-instance-data + dup to my-self instance>parent ! + get-node my-self instance>node ! +; + +: destroy-instance ( instance -- ) + dup instance>args @ ?dup IF \ Free instance args? + over instance>args-len @ free-mem + THEN + dup instance>size @ free-mem +; + +: ihandle>phandle ( ihandle -- phandle ) + dup 0= ABORT" no current instance" instance>node @ +; + +: push-my-self ( ihandle -- ) r> my-self >r >r to my-self ; +: pop-my-self ( -- ) r> r> to my-self >r ; +: call-package push-my-self execute pop-my-self ; +: $call-static ( ... str len node -- ??? ) +\ cr ." call for " 3dup -rot type ." on node " . + find-method IF execute ELSE -1 throw THEN +; + +: $call-my-method ( str len -- ) + my-self ihandle>phandle $call-static +; + +: $call-method ( str len ihandle -- ) + push-my-self + ['] $call-my-method CATCH ?dup IF + pop-my-self THROW + THEN + pop-my-self +; + +0 VALUE calling-child + +: $call-parent + my-self ihandle>phandle TO calling-child + my-parent $call-method + 0 TO calling-child +; diff --git a/src/roms/SLOF/slof/fs/little-endian.fs b/src/roms/SLOF/slof/fs/little-endian.fs new file mode 100644 index 0000000..6b4779e --- /dev/null +++ b/src/roms/SLOF/slof/fs/little-endian.fs @@ -0,0 +1,83 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +deadbeef here l! +here c@ de = CONSTANT ?bigendian +here c@ ef = CONSTANT ?littleendian + + +?bigendian [IF] + +: x!-le >r xbflip r> x! ; +: x@-le x@ xbflip ; + +: l!-le >r lbflip r> l! ; +: l@-le l@ lbflip ; + +: w!-le >r wbflip r> w! ; +: w@-le w@ wbflip ; + +: rx!-le >r xbflip r> rx! ; +: rx@-le rx@ xbflip ; + +: rl!-le >r lbflip r> rl! ; +: rl@-le rl@ lbflip ; + +: rw!-le >r wbflip r> rw! ; +: rw@-le rw@ wbflip ; + +: l!-be l! ; +: l@-be l@ ; + +: w!-be w! ; +: w@-be w@ ; + +: rl!-be rl! ; +: rl@-be rl@ ; + +: rw!-be rw! ; +: rw@-be rw@ ; + + +[ELSE] + +: x!-le x! ; +: x@-le x@ ; + +: l!-le l! ; +: l@-le l@ ; + +: w!-le w! ; +: w@-le w@ ; + +: rx!-le rx! ; +: rx@-le rx@ ; + +: rl!-le rl! ; +: rl@-le rl@ ; + +: rw!-le rw! ; +: rw@-le rw@ ; + +: l!-be >r lbflip r> l! ; +: l@-be l@ lbflip ; + +: w!-be >r wbflip r> w! ; +: w@-be w@ wbflip ; + +: rl!-be >r lbflip r> rl! ; +: rl@-be rl@ lbflip ; + +: rw!-be >r wbflip r> rw! ; +: rw@-be rw@ wbflip ; + +[THEN] diff --git a/src/roms/SLOF/slof/fs/loaders.fs b/src/roms/SLOF/slof/fs/loaders.fs new file mode 100644 index 0000000..276ba6b --- /dev/null +++ b/src/roms/SLOF/slof/fs/loaders.fs @@ -0,0 +1,94 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ \\\\\\\\\\\\\\ Global Data +CREATE bootdevice 2 cells allot bootdevice 2 cells erase +CREATE bootargs 2 cells allot bootargs 2 cells erase +CREATE load-list 2 cells allot load-list 2 cells erase + +: start-elf ( arg len entry -- ) + msr@ 7fffffffffffffff and 2000 or ciregs >srr1 ! call-client +; + +: start-elf64 ( arg len entry r2 -- ) + msr@ 2000 or ciregs >srr1 ! + ciregs >r2 ! + call-client \ entry point is pointer to .opd +; + +: set-bootpath + s" disk" find-alias + dup IF ELSE drop s" boot-device" evaluate find-alias THEN + dup IF strdup ELSE 0 THEN + encode-string s" bootpath" set-chosen +; + +: set-netbootpath + s" net" find-alias + ?dup IF strdup encode-string s" bootpath" set-chosen THEN +; + +: set-bootargs + skipws 0 parse dup 0= IF + 2drop s" boot-file" evaluate + THEN + encode-string s" bootargs" set-chosen +; + +: .(client-exec) ( arg len -- rc ) + s" snk" romfs-lookup 0<> IF + \ Load SNK client 15 MiB after Paflof... FIXME: Hard-coded offset is ugly! + paflof-start f00000 + + elf-load-file-to-addr drop \ FIXME - check this for LE, currently its BE only + dup @ swap 8 + @ \ populate entry r2 + start-elf64 client-data + ELSE + 2drop false + THEN +; +' .(client-exec) to (client-exec) + +: .client-exec ( arg len -- rc ) set-bootargs (client-exec) ; +' .client-exec to client-exec + +: netflash ( -- rc ) s" netflash 2000000 " (parse-line) $cat set-netbootpath + client-exec +; + +: netsave ( "addr len {filename}[,params]" -- rc ) + (parse-line) dup 0> IF + s" netsave " 2swap $cat set-netbootpath client-exec + ELSE + cr + ." Usage: netsave addr len [bootp|dhcp,]filename[,siaddr][,ciaddr][,giaddr][,bootp-retries][,tftp-retries][,use_ci]" + cr 2drop + THEN +; + +: ping ( "{device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]}" -- ) + my-self >r current-node @ >r \ Save my-self + (parse-line) open-dev dup IF + dup to my-self dup ihandle>phandle set-node + dup + s" ping" rot ['] $call-method CATCH IF + cr + ." Not a pingable device" + cr 3drop + THEN + swap close-dev + ELSE + cr + ." Usage: ping device-path:[device-args,]server-ip,[client-ip],[gateway-ip][,timeout]" + cr drop + THEN + r> set-node r> to my-self \ Restore my-self +; diff --git a/src/roms/SLOF/slof/fs/logging.fs b/src/roms/SLOF/slof/fs/logging.fs new file mode 100644 index 0000000..002c480 --- /dev/null +++ b/src/roms/SLOF/slof/fs/logging.fs @@ -0,0 +1,45 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Words to write to nvram log + +defer nvramlog-write-byte + +: .nvramlog-write-byte ( byte -- ) +#if defined(DISABLE_NVRAM) || defined(RTAS_NVRAM) + drop +#else + 0 1 asm-cout +#endif +; + +' .nvramlog-write-byte to nvramlog-write-byte + +: nvramlog-write-string ( str len -- ) + dup 0> IF + 0 DO dup c@ + nvramlog-write-byte char+ LOOP + ELSE + drop + THEN drop ; + +: nvramlog-write-number ( number format -- ) + 0 swap <# 0 ?DO # LOOP #> + nvramlog-write-string ; + +: nvramlog-write-string-cr ( str len -- ) + nvramlog-write-string + a nvramlog-write-byte d nvramlog-write-byte ; + +\ as long as dual-emit is enabled +\ the string is written into NVRAM as well!! +: log-string ( str len -- ) type ; diff --git a/src/roms/SLOF/slof/fs/node.fs b/src/roms/SLOF/slof/fs/node.fs new file mode 100644 index 0000000..22bf77b --- /dev/null +++ b/src/roms/SLOF/slof/fs/node.fs @@ -0,0 +1,766 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Device nodes. + +false VALUE debug-find-component? + +VARIABLE device-tree +VARIABLE current-node +: get-node current-node @ dup 0= ABORT" No active device tree node" ; + +STRUCT + cell FIELD node>peer + cell FIELD node>parent + cell FIELD node>child + cell FIELD node>properties + cell FIELD node>words + cell FIELD node>instance-template + cell FIELD node>instance-size + cell FIELD node>space? + cell FIELD node>space + cell FIELD node>addr1 + cell FIELD node>addr2 + cell FIELD node>addr3 +END-STRUCT + +: find-method ( str len phandle -- false | xt true ) + node>words @ voc-find dup IF link> true THEN ; + +\ Instances. +#include "instance.fs" + +: create-node ( parent -- new ) + max-instance-size alloc-mem ( parent instance-mem ) + dup max-instance-size erase >r ( parent R: instance-mem ) + align wordlist >r wordlist >r ( parent R: instance-mem wl wl ) + here ( parent new R: instance-mem wl wl ) + 0 , swap , 0 , \ Set node>peer, node>parent & node>child + r> , r> , \ Set node>properties & node>words to wl + r> , /instance-header , \ Set instance-template & instance-size + FALSE , 0 , \ Set node>space? and node>space + 0 , 0 , 0 , \ Set node>addr* +; + +: peer node>peer @ ; +: parent node>parent @ ; +: child node>child @ ; +: peer dup IF peer ELSE drop device-tree @ THEN ; + + +: link ( new head -- ) \ link a new node at the end of a linked list + BEGIN dup @ WHILE @ REPEAT ! ; +: link-node ( parent child -- ) + swap dup IF node>child link ELSE drop device-tree ! THEN ; + +\ Set a node as active node. +: set-node ( phandle -- ) + current-node @ IF previous THEN + dup current-node ! + ?dup IF node>words @ also context ! THEN + definitions ; +: get-parent get-node parent ; + + +: new-node ( -- phandle ) \ active node becomes new node's parent; + \ new node becomes active node +\ XXX: change to get-node, handle root node creation specially + current-node @ dup create-node + tuck link-node dup set-node ; + +: finish-node ( -- ) + \ TODO: maybe resize the instance template buffer here (or in finish-device)? + get-node parent set-node +; + +: device-end ( -- ) 0 set-node ; + +\ Properties. +CREATE $indent 100 allot VARIABLE indent 0 indent ! +#include "property.fs" + +\ Unit address. +: #address-cells s" #address-cells" rot parent get-property + ABORT" parent doesn't have a #address-cells property!" + decode-int nip nip +; + +\ my-#address-cells returns the #address-cells property of the parent node. +\ child-#address-cells returns the #address-cells property of the current node. + +\ This is confusing in several ways: Remember that a node's address is always +\ described in the parent's address space, thus the parent's property is taken +\ into regard, rather than the own. + +\ Also, an address-cell here is always a 32bit cell, no matter whether the +\ "real" cell size is 32bit or 64bit. + +: my-#address-cells ( -- #address-cells ) + get-node #address-cells +; + +: child-#address-cells ( -- #address-cells ) + s" #address-cells" get-node get-property + ABORT" node doesn't have a #address-cells property!" + decode-int nip nip +; + +: child-#size-cells ( -- #address-cells ) + s" #size-cells" get-node get-property + ABORT" node doesn't have a #size-cells property!" + decode-int nip nip +; + +: encode-phys ( phys.hi ... phys.low -- prop len ) + encode-first? IF encode-start ELSE here 0 THEN + my-#address-cells 0 ?DO rot encode-int+ LOOP +; + +: encode-child-phys ( phys.hi ... phys.low -- prop len ) + encode-first? IF encode-start ELSE here 0 THEN + child-#address-cells 0 ?DO rot encode-int+ LOOP +; + +: encode-child-size ( size.hi ... size.low -- prop len ) + encode-first? IF encode-start ELSE here 0 THEN + child-#size-cells 0 ?DO rot encode-int+ LOOP +; + +: decode-phys + my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop + my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ; +: decode-phys-and-drop + my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop + my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ; +: reg >r encode-phys r> encode-int+ s" reg" property ; + + +: >space node>space @ ; +: >space? node>space? @ ; +: >address dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN + dup 2 > IF r@ node>addr2 @ swap THEN + 1 > IF r@ node>addr1 @ THEN r> drop ; +: >unit dup >r >address r> >space ; + +: (my-phandle) ( -- phandle ) + my-self ?dup IF + ihandle>phandle + ELSE + get-node dup 0= ABORT" no active node" + THEN +; + +: my-space ( -- phys.hi ) + (my-phandle) >space +; +: my-address (my-phandle) >address ; + +\ my-unit returns the unit address of the current _instance_ - that means +\ it returns the same values as my-space and my-address together _or_ it +\ returns a unit address that has been set manually while opening the node. +: my-unit + my-self instance>#units @ IF + 0 my-self instance>#units @ 1- DO + my-self instance>unit1 i cells + @ + -1 +LOOP + ELSE + my-self ihandle>phandle >unit + THEN +; + +\ Return lower 64 bit of address +: my-unit-64 ( -- phys.lo+1|phys.lo ) + my-unit ( phys.lo ... phys.hi ) + (my-phandle) #address-cells ( phys.lo ... phys.hi #ad-cells ) + CASE + 1 OF EXIT ENDOF + 2 OF lxjoin EXIT ENDOF + 3 OF drop lxjoin EXIT ENDOF + dup OF 2drop lxjoin EXIT ENDOF + ENDCASE +; + +: set-space get-node dup >r node>space ! true r> node>space? ! ; +: set-address my-#address-cells 1 ?DO + get-node node>space i cells + ! LOOP ; +: set-unit set-space set-address ; +: set-unit-64 ( phys.lo|phys.hi -- ) + my-#address-cells 2 <> IF + ." set-unit-64: #address-cells <> 2 " abort + THEN + xlsplit set-unit +; + +\ Never ever use this in actual code, only when debugging interactively. +\ Thank you. +: set-args ( arg-str len unit-str len -- ) + s" decode-unit" get-parent $call-static set-unit set-my-args +; + +: $cat-unit + dup parent 0= IF drop EXIT THEN + dup >space? not IF drop EXIT THEN + dup >r >unit s" encode-unit" r> parent $call-static + dup IF + dup >r here swap move s" @" $cat here r> $cat + ELSE + 2drop + THEN +; + +: $cat-instance-unit + dup parent 0= IF drop EXIT THEN + \ No instance unit, use node unit + dup instance>#units @ 0= IF + ihandle>phandle $cat-unit + EXIT + THEN + dup >r push-my-self + ['] my-unit CATCH IF pop-my-self r> drop EXIT THEN + pop-my-self + s" encode-unit" + r> ihandle>phandle parent + $call-static + dup IF + dup >r here swap move s" @" $cat here r> $cat + ELSE + 2drop + THEN +; + +\ Getting basic info about a node. +: node>name dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ; +: node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ; +: node>path + here 0 rot + BEGIN dup WHILE dup parent REPEAT + 2drop + dup 0= IF [char] / c, THEN + BEGIN + dup + WHILE + [char] / c, node>qname here over allot swap move + REPEAT + drop here 2dup - allot over - +; + +: interposed? ( ihandle -- flag ) + \ We cannot actually detect if an instance is interposed; instead, we look + \ if an instance is part of the "normal" chain that would be opened by + \ open-dev and friends, if there were no interposition. + dup instance>parent @ dup 0= IF 2drop false EXIT THEN + ihandle>phandle swap ihandle>phandle parent <> ; + +: instance>qname + dup >r interposed? IF s" %" ELSE 0 0 THEN + r@ dup ihandle>phandle node>name + rot ['] $cat-instance-unit CATCH IF drop THEN + $cat r> instance>args 2@ swap + dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN +; + +: instance>qpath \ With interposed nodes. + here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop + dup 0= IF [char] / c, THEN + BEGIN dup WHILE [char] / c, instance>qname here over allot swap move + REPEAT drop here 2dup - allot over - ; +: instance>path \ Without interposed nodes. + here 0 rot BEGIN dup WHILE + dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop + dup 0= IF [char] / c, THEN + BEGIN dup WHILE [char] / c, instance>qname here over allot swap move + REPEAT drop here 2dup - allot over - ; + +: .node node>path type ; +: pwd get-node .node ; + +: .instance instance>qpath type ; +: .chain dup instance>parent @ ?dup IF recurse THEN + cr dup . instance>qname type ; + + +\ Alias helper +defer find-node +: set-alias ( alias-name len device-name len -- ) + encode-string + 2swap s" /aliases" find-node ?dup IF + set-property + ELSE + 4drop + THEN +; + +: find-alias ( alias-name len -- false | dev-path len ) + s" /aliases" find-node dup IF + get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN + THEN +; + +: .alias ( alias-name len -- ) + find-alias dup IF type ELSE ." no alias available" THEN ; + +: (.print-alias) ( lfa -- ) + link> dup >name name>string + \ Don't print name property + 2dup s" name" string=ci IF 2drop drop + ELSE cr type space ." : " execute type + THEN ; + +: (.list-alias) ( phandle -- ) + node>properties @ cell+ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ; + +: list-alias ( -- ) + s" /aliases" find-node dup IF (.list-alias) THEN ; + +\ return next available name for aliasing or +\ false if more than MAX-ALIAS aliases found +8 CONSTANT MAX-ALIAS +1 VALUE alias-ind +: get-next-alias ( $alias-name -- $next-alias-name|FALSE ) + 2dup find-alias IF + drop + 1 TO alias-ind + BEGIN + 2dup alias-ind $cathex 2dup find-alias + WHILE + drop 2drop + alias-ind 1 + TO alias-ind + alias-ind MAX-ALIAS = IF + 2drop FALSE EXIT + THEN + REPEAT + strdup 2swap 2drop + THEN +; + +: devalias ( "{alias-name}<>{device-specifier}<cr>" -- ) + parse-word parse-word dup IF set-alias + ELSE 2drop dup IF .alias + ELSE 2drop list-alias THEN THEN ; + +\ sub-alias does a single iteration of an alias at the beginning od dev path +\ expression. de-alias will repeat this until all indirect alising is resolved +: sub-alias ( arg-str arg-len -- arg' len' | false ) + 2dup + 2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN + ( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r + ( a l l p -- R:p | a l -- R:0 ) + find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 ) + r@ IF + 2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- ) + ELSE + ( a' l' -- R:0 ) r> drop ( a' l' -- ) + THEN + ELSE + ( a l -- R:p | -- R:0 ) r> IF 2drop THEN + false ( 0 -- ) + THEN +; + +: de-alias ( arg-str arg-len -- arg' len' ) + BEGIN + over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN + WHILE + 2swap 2drop + REPEAT +; + + +\ Display the device tree. +: +indent ( not-last? -- ) + IF s" | " ELSE s" " THEN $indent indent @ + swap move 4 indent +! ; +: -indent ( -- ) -4 indent +! ; + +: ls-phandle ( node -- ) . ." : " ; + +: ls-node ( node -- ) + cr dup ls-phandle + $indent indent @ type + dup peer IF ." |-- " ELSE ." +-- " THEN + node>qname type +; + +: (ls) ( node -- ) + child BEGIN dup WHILE dup ls-node dup child IF + dup peer +indent dup recurse -indent THEN peer REPEAT drop ; + +: ls ( -- ) + get-node cr + dup ls-phandle + dup node>path type + (ls) + 0 indent ! +; + +: show-devs ( {device-specifier}<eol> -- ) + skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN ( str len ) + find-node dup 0= ABORT" No such device path" (ls) +; + + +VARIABLE interpose-node +2VARIABLE interpose-args +: interpose ( arg len phandle -- ) interpose-node ! interpose-args 2! ; + + +0 VALUE user-instance-#units +CREATE user-instance-units 4 cells allot + +\ Copy the unit information (specified by the user) that we've found during +\ "find-component" into the current instance data structure +: copy-instance-unit ( -- ) + user-instance-#units IF + user-instance-#units my-self instance>#units ! + user-instance-units my-self instance>unit1 user-instance-#units cells move + 0 to user-instance-#units + THEN +; + + +: open-node ( arg len phandle -- ihandle|0 ) + current-node @ >r my-self >r \ Save current node and instance + set-node create-instance set-my-args + copy-instance-unit + \ Execute "open" method if available, and assume default of + \ success (=TRUE) for nodes without open method: + s" open" get-node find-method IF execute ELSE TRUE THEN + 0= IF + my-self destroy-instance 0 to my-self + THEN + my-self ( ihandle|0 ) + r> to my-self r> set-node \ Restore current node and instance + \ Handle interposition: + interpose-node @ IF + my-self >r to my-self + interpose-args 2@ interpose-node @ + interpose-node off recurse + r> to my-self + THEN +; + +: close-node ( ihandle -- ) + my-self >r to my-self + s" close" ['] $call-my-method CATCH IF 2drop THEN + my-self destroy-instance r> to my-self ; + +: close-dev ( ihandle -- ) + my-self >r to my-self + BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT + r> to my-self ; + +: new-device ( -- ) + my-self new-node ( parent-ihandle phandle ) + node>instance-template @ ( parent-ihandle ihandle ) + dup to my-self ( parent-ihanlde ihandle ) + instance>parent ! + get-node my-self instance>node ! + max-instance-size my-self instance>size ! +; + +: finish-device ( -- ) + \ Set unit address to first entry of reg property if it has not been set yet + get-node >space? 0= IF + s" reg" get-node get-property 0= IF + decode-int set-space 2drop + THEN + THEN + finish-node my-parent to my-self +; + +\ Set the instance template as current instance for extending it +\ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there) +: extend-device ( phandle -- ) + my-self >r + dup set-node + node>instance-template @ + dup to my-self + r> swap instance>parent ! +; + +: split ( str len char -- left len right len ) + >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ; +: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi ) + dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap + $number IF 0 THEN r> swap >r >r REPEAT r> 3drop + BEGIN dup WHILE 1- r> swap REPEAT drop ; +: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len ) + 0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ; +: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi ) + base @ >r hex generic-decode-unit r> base ! ; +: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len ) + base @ >r hex generic-encode-unit r> base ! ; + +: hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi ) + dup 2 <> IF + hex-decode-unit + ELSE + drop + base @ >r hex + $number IF 0 0 ELSE xlsplit THEN + r> base ! + THEN +; + +: hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len ) + dup 2 <> IF + hex-encode-unit + ELSE + drop + base @ >r hex + lxjoin (u.) + r> base ! + THEN +; + +: handle-leading-/ ( path len -- path' len' ) + dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ; +: match-name ( name len node -- match? ) + over 0= IF 3drop true EXIT THEN + s" name" rot get-property IF 2drop false EXIT THEN + 1- string=ci ; \ XXX should use decode-string + +0 VALUE #search-unit +CREATE search-unit 4 cells allot + +: match-unit ( node -- match? ) + \ A node with no space is a wildcard and will always match + dup >space? IF + node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF + 2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true + ELSE drop true THEN +; +: match-node ( name len node -- match? ) + dup >r match-name r> match-unit and ; \ XXX e3d +: find-kid ( name len -- node|0 ) + dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives + 2drop get-node + ELSE + get-node child >r BEGIN r@ WHILE 2dup r@ match-node + IF 2drop r> EXIT THEN r> peer >r REPEAT + r> 3drop false + THEN ; + +: set-search-unit ( unit len -- ) + 0 to #search-unit + 0 to user-instance-#units + dup 0= IF 2drop EXIT THEN + s" #address-cells" get-node get-property THROW + decode-int to #search-unit 2drop + s" decode-unit" get-node $call-static + #search-unit 0 ?DO search-unit i cells + ! LOOP +; + +: resolve-relatives ( path len -- path' len' ) + \ handle .. + 2dup 2 = swap s" .." comp 0= and IF + get-node parent ?dup IF + set-node drop -1 + ELSE + s" Already in root node." type + THEN + THEN + \ handle . + 2dup 1 = swap c@ [CHAR] . = and IF + drop -1 + THEN +; + +\ XXX This is an old hack that allows wildcard nodes to work +\ by not having a #address-cells in the parent and no +\ decode unit. This should be removed. +\ (It appears to be still used on js2x) +: set-instance-unit ( unitaddr len -- ) + dup 0= IF 2drop 0 to user-instance-#units EXIT THEN + 2dup 0 -rot bounds ?DO + i c@ [char] , = IF 1+ THEN \ Count the commas + LOOP + 1+ dup to user-instance-#units + hex-decode-unit + user-instance-#units 0 ?DO + user-instance-units i cells + ! + LOOP +; + +: split-component ( path. -- path'. args. name. unit. ) + [char] / split 2swap ( path'. component. ) + [char] : split 2swap ( path'. args. name@unit. ) + [char] @ split ( path'. args. name. unit. ) +; + +: find-component ( path len -- path' len' args len node|0 ) + debug-find-component? IF + ." find-component for " 2dup type cr + THEN + split-component ( path'. args. name. unit. ) + debug-find-component? IF + ." -> unit =" 2dup type cr + ." -> stack =" .s cr + THEN + ['] set-search-unit CATCH IF + \ XXX: See comment in set-instance-unit + ." WARNING: Obsolete old wildcard hack " .s cr + set-instance-unit + THEN + resolve-relatives find-kid ( path' len' args len node|0 ) + + \ If resolve returned a wildcard node, and we haven't hit + \ the above gross hack then copy the unit + dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF + #search-unit dup to user-instance-#units 0 ?DO + search-unit i cells + @ user-instance-units i cells + ! + LOOP + THEN THEN + + \ XXX This can go away with the old wildcard hack + dup IF dup >space? user-instance-#units 0 > AND IF + \ User supplied a unit value, but node also has different physical unit + cr ." find-component with unit mismatch!" .s cr + drop 0 + THEN THEN +; + +: .find-node ( path len -- phandle|0 ) + current-node @ >r + handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN + BEGIN dup WHILE \ handle one component: + find-component ( path len args len node ) dup 0= IF + 3drop 2drop r> set-node 0 EXIT THEN + set-node 2drop REPEAT 2drop + get-node r> set-node ; +' .find-node to find-node +: find-node ( path len -- phandle|0 ) de-alias find-node ; + +: delete-node ( phandle -- ) + dup node>instance-template @ max-instance-size free-mem + dup node>parent @ node>child @ ( phandle 1st peer ) + 2dup = IF + node>peer @ swap node>parent @ node>child ! + EXIT + THEN + dup node>peer @ + BEGIN + 2 pick 2dup <> + WHILE + drop + nip dup node>peer @ + dup 0= IF 2drop drop unloop EXIT THEN + REPEAT + drop + node>peer @ swap node>peer ! + drop +; + +: open-dev ( path len -- ihandle|0 ) + 0 to user-instance-#units + de-alias current-node @ >r + handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN + my-self >r + 0 to my-self + 0 0 >r >r + BEGIN + dup + WHILE \ handle one component: + ( arg len ) r> r> get-node open-node to my-self + find-component ( path len args len node ) dup 0= IF + 3drop 2drop my-self close-dev + r> to my-self + r> set-node + 0 EXIT + THEN + set-node + >r >r + REPEAT + 2drop + \ open final node + r> r> get-node open-node to my-self + my-self r> to my-self r> set-node +; + +: select-dev open-dev dup to my-self ihandle>phandle set-node ; +: unselect-dev my-self close-dev 0 to my-self device-end ; + +: find-device ( str len -- ) \ set as active node + find-node dup 0= ABORT" No such device path" set-node ; +: dev parse-word find-device ; + +: (lsprop) ( node --) + dup cr $indent indent @ type ." node: " node>qname type + false +indent (.properties) cr -indent +; +: (show-children) ( node -- ) + child BEGIN + dup + WHILE + dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer + REPEAT + drop +; +: lsprop ( {device-specifier}<eol> -- ) + skipws 0 parse dup IF de-alias ELSE 2drop s" /" THEN + find-device get-node dup dup + cr ." node: " node>path type (.properties) cr (show-children) + 0 indent ! +; + + +\ node>path does not allot the memory, since it is internally only used +\ for typing. +\ The external variant needs to allot memory ! + +: (node>path) node>path ; + +: node>path ( phandle -- str len ) + node>path dup allot +; + +\ Support for support packages. + +\ The /packages node. +0 VALUE packages + +\ Find a support package (or arbitrary nodes when name is absolute) +: find-package ( name len -- false | phandle true ) + dup 0 <= IF + 2drop FALSE EXIT + THEN + \ According to IEEE 1275 Proposal 215 (Extensible Client Services Package), + \ the find-package method can be used to get the phandle of arbitrary nodes + \ (i.e. not only support packages) when the name starts with a slash. + \ Some FCODE programs depend on this behavior so let's support this, too! + over c@ [char] / = IF + find-node dup IF TRUE THEN EXIT + THEN + \ Ok, let's look for support packages instead. We can't use the standard + \ find-node stuff, as we are required to find the newest (i.e., last in our + \ tree) matching package, not just any. + 0 >r packages child + BEGIN + dup + WHILE + dup >r node>name 2over string=ci r> swap IF + r> drop dup >r + THEN + peer + REPEAT + 3drop + r> dup IF true THEN +; + +: open-package ( arg len phandle -- ihandle | 0 ) open-node ; +: close-package ( ihandle -- ) close-node ; +: $open-package ( arg len name len -- ihandle | 0 ) + find-package IF open-package ELSE 2drop false THEN ; + + +\ device tree translate-address +#include <translate.fs> diff --git a/src/roms/SLOF/slof/fs/nvram.fs b/src/roms/SLOF/slof/fs/nvram.fs new file mode 100644 index 0000000..5ea58d1 --- /dev/null +++ b/src/roms/SLOF/slof/fs/nvram.fs @@ -0,0 +1,182 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2014 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +51 CONSTANT nvram-partition-type-cpulog +\ types 53-55 are omitted because they have been used for +\ storing binary tables in the past +60 CONSTANT nvram-partition-type-sas +61 CONSTANT nvram-partition-type-sms +6e CONSTANT nvram-partition-type-debug +6f CONSTANT nvram-partition-type-history +70 CONSTANT nvram-partition-type-common +7f CONSTANT nvram-partition-type-freespace +a0 CONSTANT nvram-partition-type-linux + +: rztype ( str len -- ) \ stop at zero byte, read with nvram-c@ + 0 DO + dup i + nvram-c@ ?dup IF ( str char ) + emit + ELSE ( str ) + drop UNLOOP EXIT + THEN + LOOP +; + +create tmpStr 500 allot +: rzcount ( zstr -- str len ) + dup tmpStr >r BEGIN + dup nvram-c@ dup r> dup 1+ >r c! + WHILE + char+ + REPEAT + r> drop over - swap drop tmpStr swap +; + +: calc-header-cksum ( offset -- cksum ) + dup nvram-c@ + 10 2 DO + over I + nvram-c@ + + LOOP + wbsplit + nip +; + +: bad-header? ( offset -- flag ) + dup 2+ nvram-w@ ( offset length ) + 0= IF ( offset ) + drop true EXIT ( ) + THEN + dup calc-header-cksum ( offset checksum' ) + swap 1+ nvram-c@ ( checksum ' checksum ) + <> ( flag ) +; + +: .header ( offset -- ) + cr ( offset ) + dup bad-header? IF ( offset ) + ." BAD HEADER -- trying to print it anyway" cr + THEN + space ( offset ) + \ print type + dup nvram-c@ 2 0.r ( offset ) + space space ( offset ) + \ print length + dup 2+ nvram-w@ 10 * 5 .r ( offset ) + space space ( offset ) + \ print name + 4 + 0c rztype ( ) +; + +: .headers ( -- ) + cr cr ." Type Size Name" + cr ." ========================" + 0 BEGIN ( offset ) + dup nvram-c@ ( offset type ) + WHILE + dup .header ( offset ) + dup 2+ nvram-w@ 10 * + ( offset offset' ) + dup nvram-size < IF ( offset ) + ELSE + drop EXIT ( ) + THEN + REPEAT + drop ( ) + cr cr +; + +: reset-nvram ( -- ) + internal-reset-nvram +; + +: dump-partition ['] nvram-c@ 1 (dump) ; + +: type-no-zero ( addr len -- ) + 0 DO + dup I + dup nvram-c@ 0= IF drop ELSE nvram-c@ emit THEN + LOOP + drop +; + +: type-no-zero-part ( from-str cnt-str addr len ) + 0 DO + dup i + dup nvram-c@ 0= IF + drop + ELSE + ( from-str cnt-str addr addr+i ) + ( from-str==0 AND cnt-str > 0 ) + 3 pick 0= 3 pick 0 > AND IF + dup 1 type-no-zero + THEN + + nvram-c@ a = IF + 2 pick 0= IF + over 1- 0 max + rot drop swap + THEN + 2 pick 1- 0 max + 3 roll drop rot rot + ( from-str-- cnt-str-- addr addr+i ) + THEN + THEN + LOOP + drop +; + +: (dmesg-prepare) ( base-addr -- base-addr' addr len act-off ) + 10 - \ go back to header + dup 14 + nvram-l@ dup >r + ( base-addr act-off ) ( R: act-off ) + over over over + swap 10 + nvram-w@ + >r + ( base-addr act-off ) ( R: act-off nvram-act-addr ) + over 2 + nvram-w@ 10 * swap - over swap + ( base-addr base-addr start-size ) ( R: act-off nvram-act-addr ) + r> swap rot 10 + nvram-w@ - r> +; + +: .dmesg ( base-addr -- ) + (dmesg-prepare) >r + ( base-addr addr len ) + cr type-no-zero + ( base-addr ) ( R: act-off ) + dup 10 + nvram-w@ + r> type-no-zero +; + +: .dmesg-part ( from-str cnt-str base-addr -- ) + (dmesg-prepare) >r + ( from-str cnt-str base-addr addr len ) + >r >r -rot r> r> + ( base-addr from-str cnt-str addr len ) + cr type-no-zero-part rot + ( base-addr ) ( R: act-off ) + dup 10 + nvram-w@ + r> type-no-zero-part +; + +: dmesg-part ( from-str cnt-str -- left-from-str left-cnt-str ) + 2dup + s" ibm,CPU0log" get-named-nvram-partition IF + 2drop EXIT + THEN + drop .dmesg-part nip nip +; + +: dmesg2 ( -- ) + s" ibm,CPU1log" get-named-nvram-partition IF + ." No log partition." cr EXIT + THEN + drop .dmesg +; + +: dmesg ( -- ) + s" ibm,CPU0log" get-named-nvram-partition IF + ." No log partition." cr EXIT + THEN + drop .dmesg +; diff --git a/src/roms/SLOF/slof/fs/packages.fs b/src/roms/SLOF/slof/fs/packages.fs new file mode 100644 index 0000000..f640d8f --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages.fs @@ -0,0 +1,52 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2015 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ ============================================================================= +\ SUPPORT PACKAGES +\ ============================================================================= + + +s" packages" device-name +get-node to packages + +\ new-device +\ #include "packages/filler.fs" +\ finish-device + +new-device +#include "packages/deblocker.fs" +finish-device + +new-device +#include "packages/disk-label.fs" +finish-device + +new-device +#include "packages/fat-files.fs" +finish-device + +new-device +#include "packages/rom-files.fs" +finish-device + +new-device +#include "packages/ext2-files.fs" +finish-device + +new-device +#include "packages/obp-tftp.fs" +finish-device + +new-device +#include "packages/iso-9660.fs" +finish-device diff --git a/src/roms/SLOF/slof/fs/packages/deblocker.fs b/src/roms/SLOF/slof/fs/packages/deblocker.fs new file mode 100644 index 0000000..83cd712 --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/deblocker.fs @@ -0,0 +1,70 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ ============================================================================= +\ ============================================================================= + + +\ The deblocker. Allows block devices to be used as a (seekable) byte device. + +s" deblocker" device-name + +INSTANCE VARIABLE offset +INSTANCE VARIABLE block-size +INSTANCE VARIABLE max-transfer +INSTANCE VARIABLE my-block +INSTANCE VARIABLE adr +INSTANCE VARIABLE len +INSTANCE VARIABLE fail-count + +: open + s" block-size" ['] $call-parent CATCH IF 2drop false EXIT THEN + block-size ! + s" max-transfer" ['] $call-parent CATCH IF 2drop false EXIT THEN + max-transfer ! + block-size @ alloc-mem my-block ! + 0 offset ! + true ; +: close my-block @ block-size @ free-mem ; + +: seek ( lo hi -- status ) \ XXX: perhaps we should fail if the underlying + \ device would fail at this offset + lxjoin offset ! 0 ; +: block+remainder ( -- block# remainder ) offset @ block-size @ u/mod swap ; +: read-blocks ( addr block# #blocks -- actual ) s" read-blocks" $call-parent ; +: read ( addr len -- actual ) + dup >r len ! adr ! + \ First, handle a partial block at the start. + block+remainder dup IF ( block# offset-in-block ) + >r my-block @ swap 1 read-blocks drop + my-block @ r@ + adr @ block-size @ r> - len @ min dup >r move + r> dup negate len +! dup adr +! offset +! ELSE 2drop THEN + + \ Now, in a loop read max. max-transfer sized runs of whole blocks. + 0 fail-count ! + BEGIN len @ block-size @ >= WHILE + adr @ block+remainder drop len @ max-transfer @ min block-size @ / read-blocks + dup 0= IF + 1 fail-count +! + fail-count @ 5 >= IF r> drop EXIT THEN + ELSE + 0 fail-count ! + THEN + block-size @ * dup negate len +! dup adr +! offset +! + REPEAT + + \ And lastly, handle a partial block at the end. + len @ IF my-block @ block+remainder drop 1 read-blocks drop + my-block @ adr @ len @ move THEN + + r> ; diff --git a/src/roms/SLOF/slof/fs/packages/disk-label.fs b/src/roms/SLOF/slof/fs/packages/disk-label.fs new file mode 100644 index 0000000..e034d64 --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/disk-label.fs @@ -0,0 +1,710 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Set debug-disk-label? to true to get debug messages for the disk-label code. +false VALUE debug-disk-label? + +\ This value defines the maximum number of blocks (512b) to load from a PREP +\ partition. This is required to keep the load time in reasonable limits if the +\ PREP partition becomes big. +\ If we ever want to put a large kernel with initramfs from a PREP partition +\ we might need to increase this value. The default value is 65536 blocks (32MB) +d# 65536 value max-prep-partition-blocks +d# 4096 CONSTANT block-array-size + +s" disk-label" device-name + +0 INSTANCE VALUE partition +0 INSTANCE VALUE part-offset +0 INSTANCE VALUE disk-chrp-boot + +0 INSTANCE VALUE part-start +0 INSTANCE VALUE lpart-start +0 INSTANCE VALUE part-size +0 INSTANCE VALUE dos-logical-partitions + +0 INSTANCE VALUE block-size +0 INSTANCE VALUE block + +0 INSTANCE VALUE args +0 INSTANCE VALUE args-len + +0 INSTANCE VALUE gpt-part-size +0 INSTANCE VALUE seek-pos + + +INSTANCE VARIABLE block# \ variable to store logical sector# +INSTANCE VARIABLE hit# \ partition counter +INSTANCE VARIABLE success-flag + +\ ISO9660 specific information +0ff constant END-OF-DESC +3 constant PARTITION-ID +48 constant VOL-PART-LOC + + +\ DOS partition label (MBR) specific structures + +STRUCT + 1b8 field mbr>boot-loader + /l field mbr>disk-signature + /w field mbr>null + 40 field mbr>partition-table + /w field mbr>magic + +CONSTANT /mbr + +STRUCT + /c field part-entry>active + /c field part-entry>start-head + /c field part-entry>start-sect + /c field part-entry>start-cyl + /c field part-entry>id + /c field part-entry>end-head + /c field part-entry>end-sect + /c field part-entry>end-cyl + /l field part-entry>sector-offset + /l field part-entry>sector-count + +CONSTANT /partition-entry + +STRUCT + 8 field gpt>signature + 4 field gpt>revision + 4 field gpt>header-size + 4 field gpt>header-crc32 + 4 field gpt>reserved + 8 field gpt>current-lba + 8 field gpt>backup-lba + 8 field gpt>first-lba + 8 field gpt>last-lba + 10 field gpt>disk-guid + 8 field gpt>part-entry-lba + 4 field gpt>num-part-entry + 4 field gpt>part-entry-size + 4 field gpt>part-array-crc32 + 1a4 field gpt>reserved + +CONSTANT /gpt-header + +STRUCT + 10 field gpt-part-entry>part-type-guid + 10 field gpt-part-entry>part-guid + 8 field gpt-part-entry>first-lba + 8 field gpt-part-entry>last-lba + 8 field gpt-part-entry>attribute + 48 field gpt-part-entry>part-name + +CONSTANT /gpt-part-entry + +\ Defined by IEEE 1275-1994 (3.8.1) + +: offset ( d.rel -- d.abs ) + part-offset xlsplit d+ +; + +: seek ( pos.lo pos.hi -- status ) + offset + debug-disk-label? IF 2dup ." seek-parent: pos.hi=0x" u. ." pos.lo=0x" u. THEN + s" seek" $call-parent + debug-disk-label? IF dup ." status=" . cr THEN +; + +: read ( addr len -- actual ) + debug-disk-label? IF 2dup swap ." read-parent: addr=0x" u. ." len=" .d THEN + s" read" $call-parent + debug-disk-label? IF dup ." actual=" .d cr THEN +; + + +\ read sector to array "block" +: read-sector ( sector-number -- ) + \ block-size is 0x200 on disks, 0x800 on cdrom drives + block-size * 0 seek drop \ seek to sector + block block-size read drop \ read sector +; + +: (.part-entry) ( part-entry ) + cr ." part-entry>active: " dup part-entry>active c@ .d + cr ." part-entry>start-head: " dup part-entry>start-head c@ .d + cr ." part-entry>start-sect: " dup part-entry>start-sect c@ .d + cr ." part-entry>start-cyl: " dup part-entry>start-cyl c@ .d + cr ." part-entry>id: " dup part-entry>id c@ .d + cr ." part-entry>end-head: " dup part-entry>end-head c@ .d + cr ." part-entry>end-sect: " dup part-entry>end-sect c@ .d + cr ." part-entry>end-cyl: " dup part-entry>end-cyl c@ .d + cr ." part-entry>sector-offset: " dup part-entry>sector-offset l@-le .d + cr ." part-entry>sector-count: " dup part-entry>sector-count l@-le .d + cr +; + +: (.name) r@ begin cell - dup @ <colon> = UNTIL xt>name cr type space ; + +: init-block ( -- ) + s" block-size" ['] $call-parent CATCH IF ABORT" parent has no block-size." THEN + to block-size + block-array-size alloc-mem + dup block-array-size erase + to block + debug-disk-label? IF + ." init-block: block-size=" block-size .d ." block=0x" block u. cr + THEN +; + +: partition>part-entry ( partition -- part-entry ) + 1- /partition-entry * block mbr>partition-table + +; + +: partition>start-sector ( partition -- sector-offset ) + partition>part-entry part-entry>sector-offset l@-le +; + +\ This word returns true if the currently loaded block has _NO_ MBR magic +: no-mbr? ( -- true|false ) + 0 read-sector + 1 partition>part-entry part-entry>id c@ ee = IF TRUE EXIT THEN \ GPT partition found + block mbr>magic w@-le aa55 <> +; + +\ This word returns true if the currently loaded block has _NO_ GPT partition id +: no-gpt? ( -- true|false ) + 0 read-sector + 1 partition>part-entry part-entry>id c@ ee <> IF true EXIT THEN + block mbr>magic w@-le aa55 <> +; + +: pc-extended-partition? ( part-entry-addr -- true|false ) + part-entry>id c@ ( id ) + dup 5 = swap ( true|false id ) + dup f = swap ( true|false true|false id ) + 85 = ( true|false true|false true|false ) + or or ( true|false ) +; + +: count-dos-logical-partitions ( -- #logical-partitions ) + no-mbr? IF 0 EXIT THEN + 0 5 1 DO ( current ) + i partition>part-entry ( current part-entry ) + dup pc-extended-partition? IF + part-entry>sector-offset l@-le ( current sector ) + dup to part-start to lpart-start ( current ) + BEGIN + part-start read-sector \ read EBR + 1 partition>start-sector IF + \ ." Logical Partition found at " part-start .d cr + 1+ + THEN \ another logical partition + 2 partition>start-sector + ( current relative-sector ) + ?dup IF lpart-start + to part-start false ELSE true THEN + UNTIL + ELSE + drop + THEN + LOOP +; + +: (get-dos-partition-params) ( ext-part-start part-entry -- offset count active? id ) + dup part-entry>sector-offset l@-le rot + swap ( offset part-entry ) + dup part-entry>sector-count l@-le swap ( offset count part-entry ) + dup part-entry>active c@ 80 = swap ( offset count active? part-entry ) + part-entry>id c@ ( offset count active? id ) +; + +: find-dos-partition ( partition# -- false | offset count active? id true ) + to partition 0 to part-start 0 to part-offset + + \ no negative partitions + partition 0<= IF 0 to partition false EXIT THEN + + \ load MBR and check it + no-mbr? IF 0 to partition false EXIT THEN + + partition 4 <= IF \ Is this a primary partition? + 0 partition partition>part-entry + (get-dos-partition-params) + \ FIXME sanity checks? + true EXIT + ELSE + partition 4 - 0 5 1 DO ( logical-partition current ) + i partition>part-entry ( log-part current part-entry ) + dup pc-extended-partition? IF + part-entry>sector-offset l@-le ( log-part current sector ) + dup to part-start to lpart-start ( log-part current ) + BEGIN + part-start read-sector \ read EBR + 1 partition>start-sector IF \ first partition entry + 1+ 2dup = IF ( log-part current ) + 2drop + part-start 1 partition>part-entry + (get-dos-partition-params) + true UNLOOP EXIT + THEN + 2 partition>start-sector + ( log-part current relative-sector ) + + ?dup IF lpart-start + to part-start false ELSE true THEN + ELSE + true + THEN + UNTIL + ELSE + drop + THEN + LOOP + 2drop false + THEN +; + +: try-dos-partition ( -- okay? ) + \ Read partition table and check magic. + no-mbr? IF + debug-disk-label? IF cr ." No DOS disk-label found." cr THEN + false EXIT + THEN + + count-dos-logical-partitions TO dos-logical-partitions + + debug-disk-label? IF + ." Found " dos-logical-partitions .d ." logical partitions" cr + ." Partition = " partition .d cr + THEN + + partition 1 5 dos-logical-partitions + + within 0= IF + cr ." Partition # not 1-" 4 dos-logical-partitions + . cr false EXIT + THEN + + \ Could/should check for valid partition here... the magic is not enough really. + + \ Get the partition offset. + + partition find-dos-partition IF + ( offset count active? id ) + 2drop + to part-size + block-size * to part-offset + true + ELSE + false + THEN +; + +\ Check for an ISO-9660 filesystem on the disk +\ : try-iso9660-partition ( -- true|false ) +\ implement me if you can ;-) +\ ; + + +\ Check for an ISO-9660 filesystem on the disk +\ (cf. CHRP IEEE 1275 spec., chapter 11.1.2.3) +: has-iso9660-filesystem ( -- TRUE|FALSE ) + \ Seek to the beginning of logical 2048-byte sector 16 + \ refer to Chapter C.11.1 in PAPR 2.0 Spec + \ was: 10 read-sector, but this might cause trouble if you + \ try booting an ISO image from a device with 512b sectors. + 10 800 * 0 seek drop \ seek to sector + block 800 read drop \ read sector + \ Check for CD-ROM volume magic: + block c@ 1 = + block 1+ 5 s" CD001" str= + and + dup IF 800 to block-size THEN +; + + +\ Load from first active DOS boot partition. + +: fat-bootblock? ( addr -- flag ) + \ byte 0-2 of the bootblock is a jump instruction in + \ all FAT filesystems. + \ e9 and eb are jump instructions in x86 assembler. + dup c@ e9 = IF drop true EXIT THEN + dup c@ eb = swap 2+ c@ 90 = and +; + +\ NOTE: block-size is always 512 bytes for DOS partition tables. + +: load-from-dos-boot-partition ( addr -- size ) + no-mbr? IF drop FALSE EXIT THEN \ read MBR and check for DOS disk-label magic + + count-dos-logical-partitions TO dos-logical-partitions + + debug-disk-label? IF + ." Found " dos-logical-partitions .d ." logical partitions" cr + ." Partition = " partition .d cr + THEN + + \ Now walk through the partitions: + 5 dos-logical-partitions + 1 DO + \ ." checking partition " i . + i find-dos-partition IF ( addr offset count active? id ) + 41 = and ( addr offset count prep-boot-part? ) + IF ( addr offset count ) + max-prep-partition-blocks min \ reduce load size + swap ( addr count offset ) + block-size * to part-offset + 0 0 seek drop ( addr offset ) + block-size * read ( size ) + UNLOOP EXIT + ELSE + 2drop ( addr ) + THEN + THEN + LOOP + drop 0 +; + +\ Check for GPT PReP partition GUID. Only first 3 blocks are +\ byte-swapped treating last two blocks as contigous for simplifying +\ comparison +9E1A2D38 CONSTANT GPT-PREP-PARTITION-1 +C612 CONSTANT GPT-PREP-PARTITION-2 +4316 CONSTANT GPT-PREP-PARTITION-3 +AA268B49521E5A8B CONSTANT GPT-PREP-PARTITION-4 + +: gpt-prep-partition? ( -- true|false ) + block gpt-part-entry>part-type-guid + dup l@-le GPT-PREP-PARTITION-1 <> IF drop false EXIT THEN + dup 4 + w@-le GPT-PREP-PARTITION-2 <> IF drop false EXIT THEN + dup 6 + w@-le GPT-PREP-PARTITION-3 <> IF drop false EXIT THEN + 8 + x@ GPT-PREP-PARTITION-4 = +; + +\ Check for GPT MSFT BASIC DATA GUID - fat based +EBD0A0A2 CONSTANT GPT-BASIC-DATA-PARTITION-1 +B9E5 CONSTANT GPT-BASIC-DATA-PARTITION-2 +4433 CONSTANT GPT-BASIC-DATA-PARTITION-3 +87C068B6B72699C7 CONSTANT GPT-BASIC-DATA-PARTITION-4 + +: gpt-basic-data-partition? ( -- true|false ) + block gpt-part-entry>part-type-guid + dup l@-le GPT-BASIC-DATA-PARTITION-1 <> IF drop false EXIT THEN + dup 4 + w@-le GPT-BASIC-DATA-PARTITION-2 <> IF drop false EXIT THEN + dup 6 + w@-le GPT-BASIC-DATA-PARTITION-3 <> IF drop false EXIT THEN + 8 + x@ GPT-BASIC-DATA-PARTITION-4 = +; + +\ +\ GPT Signature +\ ("EFI PART", 45h 46h 49h 20h 50h 41h 52h 54h) +\ +4546492050415254 CONSTANT GPT-SIGNATURE + +\ The routine checks whether the protective MBR has GPT ID and then +\ reads the gpt data from the sector. Also set the seek position and +\ the partition size used in caller routines. + +: get-gpt-partition ( -- true|false ) + no-gpt? IF false EXIT THEN + debug-disk-label? IF cr ." GPT partition found " cr THEN + 1 read-sector + block gpt>part-entry-lba x@-le + block-size * to seek-pos + block gpt>part-entry-size l@-le to gpt-part-size + gpt-part-size block-array-size > IF + cr ." GPT part size exceeds buffer allocated " cr + false exit + THEN + block gpt>signature x@ GPT-SIGNATURE = +; + +: load-from-gpt-prep-partition ( addr -- size ) + get-gpt-partition 0= IF false EXIT THEN + block gpt>num-part-entry l@-le dup 0= IF false exit THEN + 1+ 1 ?DO + seek-pos 0 seek drop + block gpt-part-size read drop gpt-prep-partition? IF + debug-disk-label? IF ." GPT PReP partition found " cr THEN + block gpt-part-entry>first-lba x@-le ( addr first-lba ) + block gpt-part-entry>last-lba x@-le ( addr first-lba last-lba) + over - 1+ ( addr first-lba blocks ) + swap ( addr blocks first-lba ) + block-size * to part-offset ( addr blocks ) + 0 0 seek drop ( addr blocks ) + block-size * read ( size ) + UNLOOP EXIT + THEN + seek-pos gpt-part-size + to seek-pos + LOOP + false +; + +: try-gpt-dos-partition ( -- true|false ) + get-gpt-partition 0= IF false EXIT THEN + block gpt>num-part-entry l@-le dup 0= IF false EXIT THEN + 1+ 1 ?DO + seek-pos 0 seek drop + block gpt-part-size read drop + gpt-basic-data-partition? IF + debug-disk-label? IF ." GPT BASIC DATA partition found " cr THEN + block gpt-part-entry>first-lba x@-le ( first-lba ) + dup to part-start ( first-lba ) + block gpt-part-entry>last-lba x@-le ( first-lba last-lba ) + over - 1+ ( first-lba s1 ) + block-size * to part-size ( first-lba ) + block-size * to part-offset ( ) + 0 0 seek drop + block block-size read drop + block fat-bootblock? ( true|false ) + UNLOOP EXIT + THEN + seek-pos gpt-part-size + to seek-pos + LOOP + false +; + +\ Extract the boot loader path from a bootinfo.txt file +\ In: address and length of buffer where the bootinfo.txt has been loaded to. +\ Out: string address and length of the boot loader (within the input buffer) +\ or a string with length = 0 when parsing failed. + +\ Here is a sample bootinfo file: +\ <chrp-boot> +\ <description>Linux Distribution</description> +\ <os-name>Linux</os-name> +\ <boot-script>boot &device;:1,\boot\yaboot.ibm</boot-script> +\ <icon size=64,64 color-space=3,3,2> +\ <bitmap>[..]</bitmap> +\ </icon> +\ </chrp-boot> + +: parse-bootinfo-txt ( addr len -- str len ) + 2dup s" <boot-script>" find-substr ( addr len pos1 ) + 2dup = IF + \ String not found + 3drop 0 0 EXIT + THEN + dup >r - swap r> + swap ( addr1 len1 ) + + 2dup s" &device;:" find-substr ( addr1 len1 posdev ) + 2dup = IF + 3drop 0 0 EXIT + THEN + 9 + \ Skip the "&device;:" string + dup >r - swap r> + swap ( addr2 len2 ) + 2dup s" </boot-script>" find-substr nip ( addr2 len3 ) + + debug-disk-label? IF + ." Extracted boot loader from bootinfo.txt: '" + 2dup type ." '" cr + THEN +; + +\ Try to load \ppc\bootinfo.txt from the disk (used mainly on CD-ROMs), and if +\ available, get the boot loader path from this file and load it. +\ See the "CHRP system binding to IEEE 1275" specification for more information +\ about bootinfo.txt. An example file can be found in the comment of +\ parse-bootinfo-txt ( addr len -- str len ) + +: load-chrp-boot-file ( addr -- size ) + \ Create bootinfo.txt path name and load that file: + my-parent instance>path + disk-chrp-boot @ 1 = IF + s" :1,\ppc\bootinfo.txt" $cat strdup ( addr str len ) + ELSE + s" :\ppc\bootinfo.txt" $cat strdup ( addr str len ) + THEN + open-dev dup 0= IF 2drop 0 EXIT THEN + >r dup ( addr addr R:ihandle ) + dup s" load" r@ $call-method ( addr addr size R:ihandle ) + r> close-dev ( addr addr size ) + + \ Now parse the information from bootinfo.txt: + parse-bootinfo-txt ( addr fnstr fnlen ) + dup 0= IF 3drop 0 EXIT THEN + \ Does the string contain parameters (i.e. a white space)? + 2dup 20 findchar IF + ( addr fnstr fnlen offset ) + >r 2dup r@ - 1- swap r@ + 1+ swap ( addr fnstr fnlen pstr plen R: offset ) + encode-string s" bootargs" set-chosen + drop r> + THEN + + \ Create the full path to the boot loader: + my-parent instance>path ( addr fnstr fnlen nstr nlen ) + s" :" $cat 2swap $cat strdup ( addr str len ) + \ Update the bootpath: + 2dup encode-string s" bootpath" set-chosen + \ And finally load the boot loader itself: + open-dev dup 0= IF ." failed to load CHRP boot loader." 2drop 0 EXIT THEN + >r s" load" r@ $call-method ( size R:ihandle ) + r> close-dev ( size ) +; + +\ load from a bootable partition +: load-from-boot-partition ( addr -- size ) + debug-disk-label? IF ." Trying DOS boot " .s cr THEN + dup load-from-dos-boot-partition ?dup 0 <> IF nip EXIT THEN + + debug-disk-label? IF ." Trying CHRP boot " .s cr THEN + 1 disk-chrp-boot ! + dup load-chrp-boot-file ?dup 0 <> IF nip EXIT THEN + 0 disk-chrp-boot ! + + debug-disk-label? IF ." Trying GPT boot " .s cr THEN + load-from-gpt-prep-partition + \ More boot partition formats ... +; + +\ parse partition number from my-args + +\ my-args has the following format +\ [<partition>[,<path>]] + +\ | example my-args | example boot command | +\ +------------------+---------------------------+ +\ | 1,\boot\vmlinuz | boot disk:1,\boot\vmlinuz | +\ | 2 | boot disk:2 | + +\ 0 means the whole disk, this is the same behavior +\ as if no partition is specified (yaboot wants this). + +: parse-partition ( -- okay? ) + 0 to partition + 0 to part-offset + 0 to part-size + + my-args to args-len to args + + debug-disk-label? IF + cr ." disk-label parse-partition: my-args=" my-args type cr + THEN + + \ Called without arguments? + args-len 0 = IF true EXIT THEN + + \ Check for "full disk" arguments. + my-args [char] , findchar 0= IF \ no comma? + args c@ isdigit not IF \ ... and not a partition number? + true EXIT \ ... then it's not a partition we can parse + THEN + ELSE + drop + THEN + my-args [char] , split to args-len to args + dup 0= IF 2drop true EXIT THEN \ no first argument + + \ Check partition #. + base @ >r decimal $number r> base ! + IF cr ." Not a partition #" false EXIT THEN + + \ Store part #, done. + to partition + true +; + + +\ try-files and try-partitions + +: (interpose-filesystem) ( str len -- ) + find-package IF args args-len rot interpose THEN +; + +: try-dos-files ( -- found? ) + no-mbr? IF false EXIT THEN + + block fat-bootblock? 0= IF false EXIT THEN + s" fat-files" (interpose-filesystem) + true +; + +: try-ext2-files ( -- found? ) + 2 read-sector \ read first superblock + block d# 56 + w@-le \ fetch s_magic + ef53 <> IF false EXIT THEN \ s_magic found? + s" ext2-files" (interpose-filesystem) + true +; + + +: try-iso9660-files + has-iso9660-filesystem 0= IF false exit THEN + s" iso-9660" (interpose-filesystem) + true +; + +: try-files ( -- found? ) + \ If no path, then full disk. + args-len 0= IF true EXIT THEN + + try-dos-files IF true EXIT THEN + try-ext2-files IF true EXIT THEN + try-iso9660-files IF true EXIT THEN + + \ ... more filesystem types here ... + + false +; + +: try-partitions ( -- found? ) + try-dos-partition IF try-files EXIT THEN + try-gpt-dos-partition IF try-files EXIT THEN + \ try-iso9660-partition IF try-files EXIT THEN + \ ... more partition types here... + false +; + +\ Interface functions for disk-label package +\ as defined by IEEE 1275-1994 3.8.1 + +: close ( -- ) + debug-disk-label? IF ." Closing disk-label: block=0x" block u. ." block-size=" block-size .d cr THEN + block block-array-size free-mem +; + + +: open ( -- true|false ) + init-block + + parse-partition 0= IF + close + false EXIT + THEN + + partition IF + try-partitions + ELSE + try-files + THEN + dup 0= IF debug-disk-label? IF ." not found." cr THEN close THEN \ free memory again +; + + +\ Boot & Load w/o arguments is assumed to be boot from boot partition + +: load ( addr -- size ) + debug-disk-label? IF + ." load: " dup u. cr + THEN + + args-len IF + TRUE ABORT" Load done w/o filesystem" + ELSE + partition IF + 0 0 seek drop + part-size IF + part-size max-prep-partition-blocks min \ Load size + ELSE + max-prep-partition-blocks + THEN + 200 * read + ELSE + has-iso9660-filesystem IF + dup load-chrp-boot-file ?dup 0 > IF nip EXIT THEN + THEN + load-from-boot-partition + dup 0= ABORT" No boot partition found" + THEN + THEN +; diff --git a/src/roms/SLOF/slof/fs/packages/ext2-files.fs b/src/roms/SLOF/slof/fs/packages/ext2-files.fs new file mode 100644 index 0000000..262c64a --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/ext2-files.fs @@ -0,0 +1,188 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +s" ext2-files" device-name + +INSTANCE VARIABLE first-block +INSTANCE VARIABLE inode-size +INSTANCE VARIABLE block-size +INSTANCE VARIABLE inodes/group + +INSTANCE VARIABLE group-desc-size +INSTANCE VARIABLE group-descriptors + +: seek s" seek" $call-parent ; +: read s" read" $call-parent ; + +INSTANCE VARIABLE data +INSTANCE VARIABLE #data +INSTANCE VARIABLE indirect-block +INSTANCE VARIABLE dindirect-block + +: free-data + data @ ?dup IF #data @ free-mem 0 data ! THEN ; +: read-data ( offset size -- ) + free-data dup #data ! alloc-mem data ! + xlsplit seek -2 and ABORT" ext2-files read-data: seek failed" + data @ #data @ read #data @ <> ABORT" ext2-files read-data: read failed" ; + +: read-block ( block# -- ) + block-size @ * block-size @ read-data ; + +INSTANCE VARIABLE inode +INSTANCE VARIABLE file-len +INSTANCE VARIABLE blocks +INSTANCE VARIABLE #blocks +INSTANCE VARIABLE ^blocks +INSTANCE VARIABLE #blocks-left +: blocks-read ( n -- ) dup negate #blocks-left +! 4 * ^blocks +! ; +: read-indirect-blocks ( indirect-block# -- ) + read-block data @ data off + dup #blocks-left @ 4 * block-size @ min dup >r ^blocks @ swap move + r> 2 rshift blocks-read block-size @ free-mem ; + +: read-double-indirect-blocks ( double-indirect-block# -- ) + \ Resolve one level of indirection and call read-indirect-block + read-block data @ indirect-block ! data off + BEGIN + indirect-block @ l@-le dup 0 <> + WHILE + read-indirect-blocks + 4 indirect-block +! \ point to next indirect block + REPEAT + drop \ drop 0, the invalid block number +; + +: read-triple-indirect-blocks ( triple-indirect-block# -- ) + \ Resolve one level of indirection and call double-indirect-block + read-block data @ dindirect-block ! data off + BEGIN + dindirect-block @ l@-le dup 0 <> + WHILE + read-double-indirect-blocks + 4 dindirect-block +! \ point to next double indirect block + REPEAT + drop \ drop 0, the invalid block number +; + +: read-block#s ( -- ) + blocks @ ?dup IF #blocks @ 4 * free-mem THEN + inode @ 4 + l@-le file-len ! + file-len @ block-size @ // #blocks ! + #blocks @ 4 * alloc-mem blocks ! + blocks @ ^blocks ! #blocks @ #blocks-left ! + #blocks-left @ c min \ # direct blocks + inode @ 28 + over 4 * ^blocks @ swap move blocks-read + #blocks-left @ IF inode @ 58 + l@-le read-indirect-blocks THEN + #blocks-left @ IF inode @ 5c + l@-le read-double-indirect-blocks THEN + #blocks-left @ IF inode @ 60 + l@-le read-triple-indirect-blocks THEN ; +: read-inode ( inode# -- ) + 1- inodes/group @ u/mod \ # in group, group # + 20 * group-descriptors @ + 8 + l@-le block-size @ * \ # in group, inode table + swap inode-size @ * + xlsplit seek drop inode @ inode-size @ read drop +; + +: .rwx ( bits last-char-if-special special? -- ) + rot dup 4 and IF ." r" ELSE ." -" THEN + dup 2 and IF ." w" ELSE ." -" THEN + swap IF 1 and 0= IF upc THEN emit ELSE + 1 and IF ." x" ELSE ." -" THEN drop THEN ; +CREATE mode-chars 10 allot s" ?pc?d?b?-?l?s???" mode-chars swap move +: .mode ( mode -- ) + dup c rshift f and mode-chars + c@ emit + dup 6 rshift 7 and over 800 and 73 swap .rwx + dup 3 rshift 7 and over 400 and 73 swap .rwx + dup 7 and swap 200 and 74 swap .rwx ; +: .inode ( -- ) + base @ >r decimal + inode @ w@-le .mode \ file mode + inode @ 1a + w@-le 5 .r \ link count + inode @ 02 + w@-le 9 .r \ uid + inode @ 18 + w@-le 9 .r \ gid + inode @ 04 + l@-le 9 .r \ size + r> base ! ; + +: do-super ( -- ) + 400 400 read-data + data @ 14 + l@-le first-block ! + 400 data @ 18 + l@-le lshift block-size ! + data @ 28 + l@-le inodes/group ! + \ Check revision level... in revision 0, the inode size is always 128 + data @ 4c + l@-le 0= IF + 80 inode-size ! + ELSE + data @ 58 + w@-le inode-size ! + THEN + data @ 20 + l@-le group-desc-size ! + + \ Read the group descriptor table: + first-block @ 1+ block-size @ * + group-desc-size @ + read-data + data @ group-descriptors ! + + \ We keep the group-descriptor memory area, so clear data pointer: + data off +; + +INSTANCE VARIABLE current-pos + +: read ( adr len -- actual ) + file-len @ current-pos @ - min \ can't go past end of file + current-pos @ block-size @ u/mod 4 * blocks @ + l@-le read-block + block-size @ over - rot min >r ( adr off r: len ) + data @ + swap r@ move r> dup current-pos +! ; +: read ( adr len -- actual ) + ( check if a file is selected, first ) + dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" ext2-files: read failed" + /string REPEAT 2drop r> ; +: seek ( lo hi -- status ) + lxjoin dup file-len @ > IF drop true EXIT THEN current-pos ! false ; +: load ( adr -- len ) + file-len @ read dup file-len @ <> ABORT" ext2-files: failed loading file" ; + +: .name ( adr -- ) dup 8 + swap 6 + c@ type ; +: read-dir ( inode# -- adr ) + read-inode read-block#s file-len @ alloc-mem + 0 0 seek ABORT" ext2-files read-dir: seek failed" + dup file-len @ read file-len @ <> ABORT" ext2-files read-dir: read failed" ; +: .dir ( inode# -- ) + read-dir dup BEGIN 2dup file-len @ - > over l@-le tuck and WHILE + cr dup 8 0.r space read-inode .inode space space dup .name + dup 4 + w@-le + REPEAT 2drop file-len @ free-mem ; +: (find-file) ( adr name len -- inode#|0 ) + 2>r dup BEGIN 2dup file-len @ - > over l@-le and WHILE + dup 8 + over 6 + c@ 2r@ str= IF 2r> 2drop nip l@-le EXIT THEN + dup 4 + w@-le + REPEAT 2drop 2r> 2drop 0 ; +: find-file ( inode# name len -- inode#|0 ) + 2>r read-dir dup 2r> (find-file) swap file-len @ free-mem ; +: find-path ( inode# name len -- inode#|0 ) + dup 0= IF 3drop 0 ." empty name " EXIT THEN + over c@ [char] \ = IF 1 /string ." slash " RECURSE EXIT THEN + [char] \ split 2>r find-file ?dup 0= IF + 2r> 2drop false ." not found " EXIT THEN + r@ 0<> IF 2r> ." more... " RECURSE EXIT THEN + 2r> 2drop ." got it " ; + +: close + inode @ inode-size @ free-mem + group-descriptors @ group-desc-size @ free-mem + free-data + blocks @ ?dup IF #blocks @ 4 * free-mem THEN +; + +: open + 0 data ! 0 blocks ! 0 #blocks ! + do-super + inode-size @ alloc-mem inode ! + my-args nip 0= IF 0 0 ELSE + 2 my-args find-path ?dup 0= IF close false EXIT THEN THEN + read-inode read-block#s 0 0 seek 0= ; diff --git a/src/roms/SLOF/slof/fs/packages/fat-files.fs b/src/roms/SLOF/slof/fs/packages/fat-files.fs new file mode 100644 index 0000000..0cec366 --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/fat-files.fs @@ -0,0 +1,188 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +s" fat-files" device-name + +INSTANCE VARIABLE bytes/sector +INSTANCE VARIABLE sectors/cluster +INSTANCE VARIABLE #reserved-sectors +INSTANCE VARIABLE #fats +INSTANCE VARIABLE #root-entries +INSTANCE VARIABLE total-#sectors +INSTANCE VARIABLE media-descriptor +INSTANCE VARIABLE sectors/fat +INSTANCE VARIABLE sectors/track +INSTANCE VARIABLE #heads +INSTANCE VARIABLE #hidden-sectors + +INSTANCE VARIABLE fat-type +INSTANCE VARIABLE bytes/cluster +INSTANCE VARIABLE fat-offset +INSTANCE VARIABLE root-offset +INSTANCE VARIABLE cluster-offset +INSTANCE VARIABLE #clusters + +: seek s" seek" $call-parent ; +: read s" read" $call-parent ; + +INSTANCE VARIABLE data +INSTANCE VARIABLE #data + +: free-data + data @ ?dup IF #data @ free-mem 0 data ! THEN ; +: read-data ( offset size -- ) + free-data dup #data ! alloc-mem data ! + xlsplit seek -2 and ABORT" fat-files read-data: seek failed" + data @ #data @ read #data @ <> ABORT" fat-files read-data: read failed" ; + +CREATE fat-buf 8 allot +: read-fat ( cluster# -- data ) + fat-buf 8 erase + 1 #split fat-type @ * 2/ 2/ fat-offset @ + + xlsplit seek -2 and ABORT" fat-files read-fat: seek failed" + fat-buf 8 read 8 <> ABORT" fat-files read-fat: read failed" + fat-buf 8c@ bxjoin fat-type @ dup >r 2* #split drop r> #split + rot IF swap THEN drop ; + +INSTANCE VARIABLE next-cluster + +: read-cluster ( cluster# -- ) + dup bytes/cluster @ * cluster-offset @ + bytes/cluster @ read-data + read-fat dup #clusters @ >= IF drop 0 THEN next-cluster ! ; +: read-dir ( cluster# -- ) + ?dup 0= IF root-offset @ #root-entries @ 20 * read-data 0 next-cluster ! + ELSE read-cluster THEN ; + +: .time ( x -- ) + base @ >r decimal + b #split 2 0.r [char] : emit 5 #split 2 0.r [char] : emit 2* 2 0.r + r> base ! ; +: .date ( x -- ) + base @ >r decimal + 9 #split 7bc + 4 0.r [char] - emit 5 #split 2 0.r [char] - emit 2 0.r + r> base ! ; +: .attr ( attr -- ) + 6 0 DO dup 1 and IF s" RHSLDA" drop i + c@ ELSE bl THEN emit u2/ LOOP drop ; +: .dir-entry ( adr -- ) + dup 0b + c@ 8 and IF drop EXIT THEN \ volume label, not a file + dup c@ e5 = IF drop EXIT THEN \ deleted file + cr + dup 1a + 2c@ bwjoin [char] # emit 4 0.r space \ starting cluster + dup 18 + 2c@ bwjoin .date space + dup 16 + 2c@ bwjoin .time space + dup 1c + 4c@ bljoin base @ decimal swap a .r base ! space \ size in bytes + dup 0b + c@ .attr space + dup 8 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT type + dup 8 + 3 BEGIN 2dup 1- + c@ 20 = over and WHILE 1- REPEAT dup IF + [char] . emit type ELSE 2drop THEN + drop ; +: .dir-entries ( adr n -- ) + 0 ?DO dup i 20 * + dup c@ 0= IF drop LEAVE THEN .dir-entry LOOP drop ; +: .dir ( cluster# -- ) + read-dir BEGIN data @ #data @ 20 / .dir-entries next-cluster @ WHILE + next-cluster @ read-cluster REPEAT ; + +: str-upper ( str len adr -- ) \ Copy string to adr, uppercase + -rot bounds ?DO i c@ upc over c! char+ LOOP drop ; +CREATE dos-name b allot +: make-dos-name ( str len -- ) + dos-name b bl fill + 2dup [char] . findchar IF + 3dup 1+ /string 3 min dos-name 8 + str-upper nip THEN + 8 min dos-name str-upper ; + +: (find-file) ( -- cluster file-len is-dir? true | false ) + data @ BEGIN dup data @ #data @ + < WHILE + dup dos-name b comp WHILE 20 + REPEAT + dup 1a + 2c@ bwjoin swap dup 1c + 4c@ bljoin swap 0b + c@ 10 and 0<> true + ELSE drop false THEN ; +: find-file ( dir-cluster name len -- cluster file-len is-dir? true | false ) + make-dos-name read-dir BEGIN (find-file) 0= WHILE next-cluster @ WHILE + next-cluster @ read-cluster REPEAT false ELSE true THEN ; +: find-path ( dir-cluster name len -- cluster file-len true | false ) + dup 0= IF 3drop false ." empty name " EXIT THEN + over c@ [char] \ = IF 1 /string RECURSE EXIT THEN + [char] \ split 2>r find-file 0= IF 2r> 2drop false ." not found " EXIT THEN + r@ 0<> <> IF 2drop 2r> 2drop false ." no dir<->file match " EXIT THEN + r@ 0<> IF drop 2r> RECURSE EXIT THEN + 2r> 2drop true ; + +: do-super ( -- ) + 0 200 read-data + data @ 0b + 2c@ bwjoin bytes/sector ! + data @ 0d + c@ sectors/cluster ! + bytes/sector @ sectors/cluster @ * bytes/cluster ! + data @ 0e + 2c@ bwjoin #reserved-sectors ! + data @ 10 + c@ #fats ! + data @ 11 + 2c@ bwjoin #root-entries ! + data @ 13 + 2c@ bwjoin total-#sectors ! + data @ 15 + c@ media-descriptor ! + data @ 16 + 2c@ bwjoin sectors/fat ! + data @ 18 + 2c@ bwjoin sectors/track ! + data @ 1a + 2c@ bwjoin #heads ! + data @ 1c + 2c@ bwjoin #hidden-sectors ! + + \ For FAT16 and FAT32: + total-#sectors @ 0= IF data @ 20 + 4c@ bljoin total-#sectors ! THEN + + \ For FAT32: + sectors/fat @ 0= IF data @ 24 + 4c@ bljoin sectors/fat ! THEN + + \ XXX add other FAT32 stuff (offsets 28, 2c, 30) + + \ Compute the number of data clusters, decide what FAT type we are. + total-#sectors @ #reserved-sectors @ - sectors/fat @ #fats @ * - + #root-entries @ 20 * bytes/sector @ // - sectors/cluster @ / + dup #clusters ! + dup ff5 < IF drop c ELSE fff5 < IF 10 ELSE 20 THEN THEN fat-type ! + base @ decimal base ! + + \ Starting offset of first fat. + #reserved-sectors @ bytes/sector @ * fat-offset ! + + \ Starting offset of root dir. + #fats @ sectors/fat @ * bytes/sector @ * fat-offset @ + root-offset ! + + \ Starting offset of "cluster 0". + #root-entries @ 20 * bytes/sector @ tuck // * root-offset @ + + bytes/cluster @ 2* - cluster-offset ! ; + + +INSTANCE VARIABLE file-cluster +INSTANCE VARIABLE file-len +INSTANCE VARIABLE current-pos +INSTANCE VARIABLE pos-in-data + +: seek ( lo hi -- status ) + lxjoin dup current-pos ! file-cluster @ read-cluster + \ Read and skip blocks until we are where we want to be. + BEGIN dup #data @ >= WHILE #data @ - next-cluster @ dup 0= IF + 2drop true EXIT THEN read-cluster REPEAT pos-in-data ! false ; +: read ( adr len -- actual ) + file-len @ current-pos @ - min \ can't go past end of file + #data @ pos-in-data @ - min >r \ length for this transfer + data @ pos-in-data @ + swap r@ move \ move the data + r@ pos-in-data +! r@ current-pos +! pos-in-data @ #data @ = IF + next-cluster @ ?dup IF read-cluster 0 pos-in-data ! THEN THEN r> ; +: read ( adr len -- actual ) + file-len @ min \ len cannot be greater than file size + dup >r BEGIN dup WHILE 2dup read dup 0= ABORT" fat-files: read failed" + /string ( tuck - >r + r> ) REPEAT 2drop r> ; +: load ( adr -- len ) + file-len @ read dup file-len @ <> ABORT" fat-files: failed loading file" ; + +: close free-data ; +: open + do-super + 0 my-args find-path 0= IF close false EXIT THEN + file-len ! file-cluster ! 0 0 seek 0= ; diff --git a/src/roms/SLOF/slof/fs/packages/filler.fs b/src/roms/SLOF/slof/fs/packages/filler.fs new file mode 100644 index 0000000..bd5c17a --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/filler.fs @@ -0,0 +1,21 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +s" filler" device-name + +: block-size s" block-size" $call-parent ; +: seek s" seek" $call-parent ; +: read s" read" $call-parent ; + +: open true ; +: close ; diff --git a/src/roms/SLOF/slof/fs/packages/iso-9660.fs b/src/roms/SLOF/slof/fs/packages/iso-9660.fs new file mode 100644 index 0000000..6eda8be --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/iso-9660.fs @@ -0,0 +1,325 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +s" iso-9660" device-name + + +0 VALUE iso-debug-flag + +\ Method for code clean up - For release version of code iso-debug-flag is +\ cleared and for debugging it is set + +: iso-debug-print ( str len -- ) iso-debug-flag IF type cr ELSE 2drop THEN ; + + +\ -------------------------------------------------------- +\ GLOBAL VARIABLES +\ -------------------------------------------------------- + + +0 VALUE path-tbl-size +0 VALUE path-tbl-addr +0 VALUE root-dir-size +0 VALUE vol-size +0 VALUE logical-blk-size +0 VALUE path-table +0 VALUE count + + +\ INSTANCE VARIABLES + + +INSTANCE VARIABLE dir-addr +INSTANCE VARIABLE data-buff +INSTANCE VARIABLE #data +INSTANCE VARIABLE ptable +INSTANCE VARIABLE file-loc +INSTANCE VARIABLE file-size +INSTANCE VARIABLE cur-file-offset +INSTANCE VARIABLE self +INSTANCE VARIABLE index + + +\ -------------------------------------------------------- +\ COLON DEFINITIONS +\ -------------------------------------------------------- + + +\ This method is used to seek to the required position +\ Which calls seek of disk-label + +: seek ( pos.lo pos.hi -- status ) s" seek" $call-parent ; + + +\ This method is used to read the contents of disk +\ it calls read of disk-label + + + : read ( addr len -- actual ) s" read" $call-parent ; + + +\ This method releases the memory used as scratch pad buffer. + +: free-data ( -- ) + data-buff @ ( data-buff ) + ?DUP IF #data @ free-mem 0 data-buff ! 0 #data ! THEN +; + + +\ This method will release the previous allocated scratch pad buffer and +\ allocates a fresh buffer and copies the required number of bytes from the +\ media in to it. + +: read-data ( offset size -- ) + dup #data @ > IF + free-data dup dup ( offset size size size ) + #data ! alloc-mem data-buff ! ( offset size ) + THEN + swap xlsplit ( size pos.lo pos.hi ) + seek -2 and ABORT" seek failed." + data-buff @ over read ( size actual ) + <> ABORT" read failed." +; + + +\ This method extracts the information required from primary volume +\ descriptor and stores the required information in the global variables + +: extract-vol-info ( -- ) + 10 800 * 800 read-data + data-buff @ 88 + l@-be to path-tbl-size \ read path table size + data-buff @ 94 + l@-be to path-tbl-addr \ read big-endian path table + data-buff @ a2 + l@-be dir-addr ! \ gather of root directory info + data-buff @ 0aa + l@-be to root-dir-size \ get volume info + data-buff @ 54 + l@-be to vol-size \ size in blocks + data-buff @ 82 + l@-be to logical-blk-size + path-tbl-size alloc-mem dup TO path-table path-tbl-size erase + path-tbl-addr 800 * xlsplit seek drop + path-table path-tbl-size read drop \ pathtable in-system-memory copy +; + + +\ This method coverts the iso file name to user readble form + +: file-name ( str len -- str' len' ) + 2dup [char] ; findchar IF + ( str len offset ) + nip \ Omit the trailing ";1" revision of ISO9660 file name + 2dup + 1- ( str newlen endptr ) + c@ [CHAR] . = IF + 1- ( str len' ) \ Remove trailing dot + THEN + THEN +; + + +\ triplicates top stack element + +: dup3 ( num -- num num num ) dup dup dup ; + + +\ This method is used for traversing records of path table. If the +\ file identifier length is odd 1 byte padding is done else not. + +: get-next-record ( rec-addr -- next-rec-offset ) + dup3 ( rec-addr rec-addr rec-addr rec-addr ) + self @ 1 + self ! ( rec-addr rec-addr rec-addr rec-addr ) + c@ 1 AND IF ( rec-addr rec-addr rec-addr ) + c@ + 9 ( rec-addr rec-addr' rec-len ) + ELSE + c@ + 8 ( rec-addr rec-addr' rec-len ) + THEN + + swap - ( next-rec-offset ) +; + + +\ This method does search of given directory name in the path table +\ and returns true if finds a match else false. + +: path-table-search ( str len -- TRUE | FALSE ) + path-table path-tbl-size + path-table ptable @ + DO ( str len ) + 2dup I 6 + w@-be index @ = ( str len str len ) + -rot I 8 + I c@ + iso-debug-flag IF + ." ISO: comparing path name '" + 4dup type ." ' with '" type ." '" cr + THEN + string=ci and IF ( str len ) + s" Directory Matched!! " iso-debug-print ( str len ) + self @ index ! ( str len ) + I 2 + l@-be dir-addr ! I dup ( str len rec-addr ) + get-next-record + path-table - ptable ! ( str len ) + 2drop TRUE UNLOOP EXIT ( TRUE ) + THEN + I get-next-record ( str len next-rec-offset ) + +LOOP + 2drop + FALSE ( FALSE ) + s" Invalid path / directory " iso-debug-print +; + + +\ METHOD for searching for a file with in a direcotory + +: search-file-dir ( str len -- TRUE | FALSE ) + dir-addr @ 800 * dir-addr ! ( str len ) + dir-addr @ 100 read-data ( str len ) + data-buff @ 0e + l@-be dup >r ( str len rec-len ) + 100 > IF ( str len ) + s" size dir record" iso-debug-print ( str len ) + dir-addr @ r@ read-data ( str len ) + THEN + r> data-buff @ + data-buff @ DO ( str len ) + I 19 + c@ 2 and 0= I c@ 0<> and IF ( str len ) + 2dup ( str len str len ) + I 21 + I 20 + c@ ( str len str len str' len' ) + iso-debug-flag IF + ." ISO: comparing file name '" + 4dup type ." ' with '" type ." '" cr + THEN + file-name string=ci IF ( str len ) + s" File found!" iso-debug-print ( str len ) + I 6 + l@-be 800 * ( str len file-loc ) + file-loc ! ( str len ) + I 0e + l@-be file-size ! ( str len ) + 2drop + TRUE ( TRUE ) + UNLOOP + EXIT + THEN + THEN + ( str len ) + I c@ ?dup 0= IF + 800 I 7ff AND - + iso-debug-flag IF + ." skipping " dup . ." bytes at end of sector" cr + THEN + THEN + ( str len offset ) + +LOOP + 2drop + FALSE ( FALSE ) + s" file not found" iso-debug-print +; + + +\ This method splits the given absolute path in to directories from root and +\ calls search-path-table. when string reaches to state when it can not be +\ split i.e., end of the path, calls search-file-dir is made to search for +\ file . + +: search-path ( str len -- FALSE|TRUE ) + 0 ptable ! + 1 self ! + 1 index ! + dup ( str len len ) + 0= IF + 3drop FALSE ( FALSE ) + s" Empty path name " iso-debug-print EXIT ( FALSE ) + THEN + OVER c@ ( str len char ) + [char] \ = IF ( str len ) + swap 1 + swap 1 - BEGIN ( str len ) + [char] \ split ( str len str' len ' ) + dup 0 = IF ( str len str' len ' ) + 2drop search-file-dir EXIT ( TRUE | FALSE ) + ELSE + 2swap path-table-search invert IF ( str' len ' ) + 2drop FALSE EXIT ( FALSE ) + THEN + THEN + AGAIN + ELSE BEGIN + [char] \ split dup 0 = IF ( str len str' len' ) + 2drop search-file-dir EXIT ( TRUE | FALSE ) + ELSE + 2swap path-table-search invert IF ( str' len ' ) + 2drop FALSE EXIT ( FALSE ) + THEN + THEN + AGAIN + THEN +; + + +\ this method will seek and read the file in to the given memory location + +0 VALUE loc +: load ( addr -- len ) + dup to loc ( addr ) + file-loc @ xlsplit seek drop + file-size @ read ( file-size ) + iso-debug-flag IF s" Bytes returned from read:" type dup . cr THEN + dup file-size @ <> ABORT" read failed!" +; + + + +\ memory used by the file system will be freed + +: close ( -- ) + free-data count 1 - dup to count 0 = IF + path-table path-tbl-size free-mem + 0 TO path-table + THEN +; + + +\ open method of the file system + +: open ( -- TRUE | FALSE ) + 0 data-buff ! + 0 #data ! + 0 ptable ! + 0 file-loc ! + 0 file-size ! + 0 cur-file-offset ! + 1 self ! + 1 index ! + count 0 = IF + s" extract-vol-info called " iso-debug-print + extract-vol-info + THEN + count 1 + to count + my-args search-path IF + file-loc @ xlsplit seek drop + TRUE ( TRUE ) + ELSE + close + FALSE ( FALSE ) + THEN + 0 cur-file-offset ! + s" opened ISO9660 package" iso-debug-print +; + + +\ public seek method + +: seek ( pos.lo pos.hi -- status ) + lxjoin dup cur-file-offset ! ( offset ) + file-loc @ + xlsplit ( pos.lo pos.hi ) + s" seek" $call-parent ( status ) +; + + +\ public read method + + : read ( addr len -- actual ) + file-size @ cur-file-offset @ - ( addr len remainder-of-file ) + min ( addr len|remainder-of-file ) + s" read" $call-parent ( actual ) + dup cur-file-offset @ + cur-file-offset ! ( actual ) + cur-file-offset @ ( offset actual ) + xlsplit seek drop ( actual ) +; + diff --git a/src/roms/SLOF/slof/fs/packages/obp-tftp.fs b/src/roms/SLOF/slof/fs/packages/obp-tftp.fs new file mode 100644 index 0000000..89143a6 --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/obp-tftp.fs @@ -0,0 +1,71 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +s" obp-tftp" device-name + +INSTANCE VARIABLE ciregs-buffer + +: open ( -- okay? ) + ciregs-size alloc-mem ciregs-buffer ! + true +; + +: load ( addr -- size ) + + \ Save old client interface register + ciregs ciregs-buffer @ ciregs-size move + + s" bootargs" get-chosen 0= IF 0 0 THEN >r >r + s" bootpath" get-chosen 0= IF 0 0 THEN >r >r + + \ Set bootpath to current device + my-parent ihandle>phandle node>path encode-string + s" bootpath" set-chosen + + \ Generate arg string for snk like + \ "netboot load-addr length filename" + (u.) s" netboot " 2swap $cat s" 60000000 " $cat + + \ Allocate 1720 bytes to store the BOOTP-REPLY packet + 6B8 alloc-mem dup >r (u.) $cat s" " $cat + huge-tftp-load @ IF s" 1 " ELSE s" 0 " THEN $cat + \ Add desired TFTP-Blocksize as additional argument + s" 1432 " $cat + \ Add OBP-TFTP Bootstring argument, e.g. "10.128.0.1,bootrom.bin,10.128.40.1" + my-args $cat + + \ Call SNK netboot loadr + (client-exec) dup 0< IF drop 0 THEN + + \ Restore to old client interface register + ciregs-buffer @ ciregs ciregs-size move + + \ Recover buffer address of BOOTP-REPLY packet + r> + + r> r> over IF s" bootpath" set-chosen ELSE 2drop THEN + r> r> over IF s" bootargs" set-chosen ELSE 2drop THEN + + \ Store BOOTP-REPLY packet as property + dup 6B8 encode-bytes s" bootp-response" s" /chosen" find-node set-property + + \ free buffer + 6B8 free-mem +; + +: close ( -- ) + ciregs-buffer @ ciregs-size free-mem +; + +: ping ( -- ) + s" ping " my-args $cat (client-exec) +; diff --git a/src/roms/SLOF/slof/fs/packages/rom-files.fs b/src/roms/SLOF/slof/fs/packages/rom-files.fs new file mode 100644 index 0000000..418cf4e --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/rom-files.fs @@ -0,0 +1,85 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ package which adds support to read the romfs +\ this package is somehow limited as the maximum supported length +\ for a file name is hardcoded to 0x100 + +s" rom-files" device-name + +INSTANCE VARIABLE length +INSTANCE VARIABLE next-file +INSTANCE VARIABLE buffer +INSTANCE VARIABLE buffer-size +INSTANCE VARIABLE file +INSTANCE VARIABLE file-size +INSTANCE VARIABLE found + +: open true + 100 dup buffer-size ! alloc-mem buffer ! false found ! ; +: close buffer @ buffer-size @ free-mem ; + +: read ( addr len -- actual ) s" read" $call-parent ; + +: seek ( lo hi -- status ) s" seek" $call-parent ; + +: .read-file-name ( offset -- str len ) + \ move to the file name offset + 0 seek drop + \ read <buffer-size> bytes from that address + buffer @ buffer-size @ read drop + \ write a 0 to make sure it is a 0 terminated string + buffer-size @ 1 - buffer @ + 0 swap c! + buffer @ zcount ; + +: .print-info ( offset -- ) + dup 2 spaces 6 0.r 2 spaces dup + 8 + 0 seek drop length 8 read drop + 6 length @ swap 0.r 2 spaces + 20 + .read-file-name type cr ; + +: .list-header cr + s" --offset---size-----file-name----" type cr ; + +: list + .list-header + 0 0 BEGIN + dup + .print-info dup 0 seek drop + next-file 8 read drop next-file @ + dup 0= UNTIL 2drop ; + +: (find-file) ( name len -- offset | -1 ) + 0 0 seek drop false found ! + file-size ! file ! 0 0 BEGIN + dup + 20 + .read-file-name file @ file-size @ + str= IF true found ! THEN + dup 0 seek drop + next-file 8 read drop next-file @ + dup 0= found @ or UNTIL drop found @ 0= + IF drop -1 THEN ; + +: load ( addr -- size ) + my-parent instance>args 2@ [char] \ left-parse-string 2drop + (find-file) dup -1 = IF 2drop 0 ELSE + \ got to the beginning + 0 0 seek drop + \ read the file size + dup 8 + 0 seek drop + here 8 read drop here @ ( dest-addr offset file-size ) + \ read data start offset + over 18 + 0 seek drop + here 8 read drop here @ ( dest-addr offset file-size data-offset ) + rot + 0 seek drop ( dest-addr file-size ) + read + THEN +; diff --git a/src/roms/SLOF/slof/fs/packages/sms.fs b/src/roms/SLOF/slof/fs/packages/sms.fs new file mode 100644 index 0000000..d8c672f --- /dev/null +++ b/src/roms/SLOF/slof/fs/packages/sms.fs @@ -0,0 +1,29 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +s" /packages" find-device + +new-device + s" sms" device-name + + : open true ; + + : close ; + + \ The rest of methods is loaded dynamically from the romfs + \ on a first call to sms-start + +finish-device + +device-end \ leave /packages + diff --git a/src/roms/SLOF/slof/fs/pci-bridge.fs b/src/roms/SLOF/slof/fs/pci-bridge.fs new file mode 100644 index 0000000..e6af7b6 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-bridge.fs @@ -0,0 +1,65 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ get the PUID from the node above +get-node CONSTANT my-phandle +s" my-puid" my-phandle parent $call-static CONSTANT my-puid + +\ Save the bus number provided by this bridge +pci-bus-number 1+ CONSTANT my-bus + +s" pci-config-bridge.fs" included +s" dma-function.fs" included + +\ generate the rom-fs filename from the vendor and device ID "pci-bridge_VENDORID_DEVICEID.fs" +: filename ( -- str len ) + s" pci-bridge_" + my-space pci-vendor@ 4 int2str $cat + s" _" $cat + my-space pci-device@ 4 int2str $cat + s" .fs" $cat +; + +\ Set up the Bridge with either default or special settings +: setup ( -- ) + \ is there special handling for this device, given vendor and device id? + filename romfs-lookup ?dup + IF + \ give it a special treatment + evaluate + ELSE + \ no special handling for this device, attempt autoconfiguration + my-space pci-class-name type 2a emit cr + my-space pci-bridge-generic-setup + my-space pci-reset-2nd + THEN +; + +\ Disable Bus Master, Memory Space and I/O Space for +\ this device and so for the scanning for the devices behind +pci-device-disable + +\ Enalbe #PERR and #SERR reporting +pci-error-enable + +\ Print out device information +my-space 42 pci-out \ config-addr ascii('B') + +\ and set up the bridge +setup + +\ And enable Bus Master IO and MEM access again. +\ we need that on bridges so that the devices behind +\ can set their state on their own. +pci-master-enable +pci-mem-enable +pci-io-enable diff --git a/src/roms/SLOF/slof/fs/pci-class-code-names.fs b/src/roms/SLOF/slof/fs/pci-class-code-names.fs new file mode 100644 index 0000000..f3a4945 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-class-code-names.fs @@ -0,0 +1,264 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: pci-class-name-00 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 01 OF s" display" ENDOF + dup OF s" unknown-legacy-device" ENDOF + ENDCASE +; + +: pci-class-name-01 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" scsi" ENDOF + 01 OF s" ide" ENDOF + 02 OF s" fdc" ENDOF + 03 OF s" ipi" ENDOF + 04 OF s" raid" ENDOF + 05 OF s" ata" ENDOF + 06 OF s" sata" ENDOF + 07 OF s" sas" ENDOF + dup OF s" mass-storage" ENDOF + ENDCASE +; + +: pci-class-name-02 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" ethernet" ENDOF + 01 OF s" token-ring" ENDOF + 02 OF s" fddi" ENDOF + 03 OF s" atm" ENDOF + 04 OF s" isdn" ENDOF + 05 OF s" worldfip" ENDOF + 05 OF s" picmg" ENDOF + dup OF s" network" ENDOF + ENDCASE +; + +: pci-class-name-03 ( addr -- str len ) + pci-class@ FFFF and CASE + 0000 OF s" vga" ENDOF + 0001 OF s" 8514-compatible" ENDOF + 0100 OF s" xga" ENDOF + 0200 OF s" 3d-controller" ENDOF + dup OF s" display" ENDOF + ENDCASE +; + +: pci-class-name-04 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" video" ENDOF + 01 OF s" sound" ENDOF + 02 OF s" telephony" ENDOF + dup OF s" multimedia-device" ENDOF + ENDCASE +; + +: pci-class-name-05 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" memory" ENDOF + 01 OF s" flash" ENDOF + dup OF s" memory-controller" ENDOF + ENDCASE +; + +: pci-class-name-06 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" host" ENDOF + 01 OF s" isa" ENDOF + 02 OF s" eisa" ENDOF + 03 OF s" mca" ENDOF + 04 OF s" pci" ENDOF + 05 OF s" pcmcia" ENDOF + 06 OF s" nubus" ENDOF + 07 OF s" cardbus" ENDOF + 08 OF s" raceway" ENDOF + 09 OF s" semi-transparent-pci" ENDOF + 0A OF s" infiniband" ENDOF + dup OF s" unkown-bridge" ENDOF + ENDCASE +; + +: pci-class-name-07 ( addr -- str len ) + pci-class@ FFFF and CASE + 0000 OF s" serial" ENDOF + 0001 OF s" 16450-serial" ENDOF + 0002 OF s" 16550-serial" ENDOF + 0003 OF s" 16650-serial" ENDOF + 0004 OF s" 16750-serial" ENDOF + 0005 OF s" 16850-serial" ENDOF + 0006 OF s" 16950-serial" ENDOF + 0100 OF s" parallel" ENDOF + 0101 OF s" bi-directional-parallel" ENDOF + 0102 OF s" ecp-1.x-parallel" ENDOF + 0103 OF s" ieee1284-controller" ENDOF + 01FE OF s" ieee1284-device" ENDOF + 0200 OF s" multiport-serial" ENDOF + 0300 OF s" modem" ENDOF + 0301 OF s" 16450-modem" ENDOF + 0302 OF s" 16550-modem" ENDOF + 0303 OF s" 16650-modem" ENDOF + 0304 OF s" 16750-modem" ENDOF + 0400 OF s" gpib" ENDOF + 0500 OF s" smart-card" ENDOF + dup OF s" communication-controller" ENDOF + ENDCASE +; + + +: pci-class-name-08 ( addr -- str len ) + pci-class@ FFFF and CASE + 0000 OF s" interrupt-controller" ENDOF + 0001 OF s" isa-pic" ENDOF + 0002 OF s" eisa-pic" ENDOF + 0010 OF s" io-apic" ENDOF + 0020 OF s" iox-apic" ENDOF + 0100 OF s" dma-controller" ENDOF + 0101 OF s" isa-dma" ENDOF + 0102 OF s" eisa-dma" ENDOF + 0200 OF s" timer" ENDOF + 0201 OF s" isa-system-timer" ENDOF + 0202 OF s" eisa-system-timer" ENDOF + 0300 OF s" rtc" ENDOF + 0301 OF s" isa-rtc" ENDOF + 0400 OF s" hot-plug-controller" ENDOF + 0500 OF s" sd-host-conrtoller" ENDOF + dup OF s" system-periphal" ENDOF + ENDCASE +; + +: pci-class-name-09 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" keyboard" ENDOF + 01 OF s" pen" ENDOF + 02 OF s" mouse" ENDOF + 03 OF s" scanner" ENDOF + 04 OF s" gameport" ENDOF + dup OF s" input-controller" ENDOF + ENDCASE +; + +: pci-class-name-0A ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" dock" ENDOF + dup OF s" docking-station" ENDOF + ENDCASE +; + +: pci-class-name-0B ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" 386" ENDOF + 01 OF s" 486" ENDOF + 02 OF s" pentium" ENDOF + 10 OF s" alpha" ENDOF + 20 OF s" powerpc" ENDOF + 30 OF s" mips" ENDOF + 40 OF s" co-processor" ENDOF + dup OF s" cpu" ENDOF + ENDCASE +; + +: pci-class-name-0C ( addr -- str len ) + pci-class@ FFFF and CASE + 0000 OF s" firewire" ENDOF + 0100 OF s" access-bus" ENDOF + 0200 OF s" ssa" ENDOF + 0300 OF s" usb-uhci" ENDOF + 0310 OF s" usb-ohci" ENDOF + 0320 OF s" usb-ehci" ENDOF + 0330 OF s" usb-xhci" ENDOF + 0380 OF s" usb" ENDOF + 03FE OF s" usb-device" ENDOF + 0400 OF s" fibre-channel" ENDOF + 0500 OF s" smb" ENDOF + 0600 OF s" infiniband" ENDOF + 0700 OF s" ipmi-smic" ENDOF + 0701 OF s" ipmi-kbrd" ENDOF + 0702 OF s" ipmi-bltr" ENDOF + 0800 OF s" sercos" ENDOF + 0900 OF s" canbus" ENDOF + dup OF s" serial-bus" ENDOF + ENDCASE +; + +: pci-class-name-0D ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" irda" ENDOF + 01 OF s" consumer-ir" ENDOF + 10 OF s" rf-controller" ENDOF + 11 OF s" bluetooth" ENDOF + 12 OF s" broadband" ENDOF + 20 OF s" enet-802.11a" ENDOF + 21 OF s" enet-802.11b" ENDOF + dup OF s" wireless-controller" ENDOF + ENDCASE +; + + +: pci-class-name-0E ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + dup OF s" intelligent-io" ENDOF + ENDCASE +; + +: pci-class-name-0F ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 01 OF s" satelite-tv" ENDOF + 02 OF s" satelite-audio" ENDOF + 03 OF s" satelite-voice" ENDOF + 04 OF s" satelite-data" ENDOF + dup OF s" satelite-devoce" ENDOF + ENDCASE +; + +: pci-class-name-10 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" network-encryption" ENDOF + 01 OF s" entertainment-encryption" ENDOF + dup OF s" encryption" ENDOF + ENDCASE +; + +: pci-class-name-11 ( addr -- str len ) + pci-class@ 8 rshift FF and CASE + 00 OF s" dpio" ENDOF + 01 OF s" counter" ENDOF + 10 OF s" measurement" ENDOF + 20 OF s" managment-card" ENDOF + dup OF s" data-processing-controller" ENDOF + ENDCASE +; + +\ create a string holding the predefined Class-Code-Names +: pci-class-name ( addr -- str len ) + dup pci-class@ 10 rshift CASE + 00 OF pci-class-name-00 ENDOF + 01 OF pci-class-name-01 ENDOF + 02 OF pci-class-name-02 ENDOF + 03 OF pci-class-name-03 ENDOF + 04 OF pci-class-name-04 ENDOF + 05 OF pci-class-name-05 ENDOF + 06 OF pci-class-name-06 ENDOF + 07 OF pci-class-name-07 ENDOF + 08 OF pci-class-name-08 ENDOF + 09 OF pci-class-name-09 ENDOF + 0A OF pci-class-name-0A ENDOF + 0B OF pci-class-name-0B ENDOF + 0C OF pci-class-name-0C ENDOF + 0C OF pci-class-name-0D ENDOF + 0C OF pci-class-name-0E ENDOF + 0C OF pci-class-name-0F ENDOF + 0C OF pci-class-name-10 ENDOF + 0C OF pci-class-name-11 ENDOF + dup OF drop s" unknown" ENDOF + ENDCASE +; diff --git a/src/roms/SLOF/slof/fs/pci-config-bridge.fs b/src/roms/SLOF/slof/fs/pci-config-bridge.fs new file mode 100644 index 0000000..6893253 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-config-bridge.fs @@ -0,0 +1,111 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Generic config space access function - xt is execution token of rtas-config-xx +: config-xt ( config-addr xt -- data ) + puid >r \ Safe puid + my-puid TO puid \ Set my-puid + swap dup ffff00 AND 0= IF \ Has bus-device-function been specified? + my-space OR \ No: use my-space instead + THEN + swap execute \ Execute the rtas-config-xx function + r> TO puid \ Restore previous puid +; + +\ define the config reads +: config-b@ ( config-addr -- data ) ['] rtas-config-b@ config-xt ; +: config-w@ ( config-addr -- data ) ['] rtas-config-w@ config-xt ; +: config-l@ ( config-addr -- data ) ['] rtas-config-l@ config-xt ; + +\ define the config writes +: config-b! ( data config-addr -- ) ['] rtas-config-b! config-xt ; +: config-w! ( data config-addr -- ) ['] rtas-config-w! config-xt ; +: config-l! ( data config-addr -- ) ['] rtas-config-l! config-xt ; + +\ for Debug purposes: dumps the whole config space +: config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ; + +\ needed to find the right path in the device tree +: decode-unit ( addr len -- phys.lo ... phys.hi ) + 2 hex-decode-unit \ decode string + B lshift swap \ shift the devicenumber to the right spot + 8 lshift or \ add the functionnumber + my-bus 10 lshift or \ add the busnumber + 0 0 rot \ make phys.lo = 0 = phys.mid +; + +\ needed to have the right unit address in the device tree listing +\ phys.lo=phys.mid=0 , phys.hi=config-address +: encode-unit ( phys.lo ... phys.hi -- unit-str unit-len ) + nip nip \ forget the both zeros + dup 8 rshift 7 and swap \ calc Functionnumber + B rshift 1F and \ calc Devicenumber + over IF \ IF Function!=0 + 2 hex-encode-unit \ | create string with DevNum,FnNum + ELSE \ ELSE + nip 1 hex-encode-unit \ | create string with only DevNum + THEN \ FI +; + +: map-in ( phys.lo phys.mid phys.hi size -- virt ) + \ ." map-in called: " .s cr + \ Ignore the size, phys.lo and phys.mid, get BAR from config space + drop nip nip ( phys.hi ) + \ Sanity check whether config address is in expected range: + dup FF AND dup 10 28 WITHIN NOT swap 30 <> AND IF + cr ." phys.hi = " . cr + ABORT" map-in with illegal config space address" + THEN + 00FFFFFF AND \ Need only bus-dev-fn+register bits + dup config-l@ ( phys.hi' bar.lo ) + dup 7 AND 4 = IF \ Is it a 64-bit BAR? + swap 4 + config-l@ lxjoin \ Add upper part of 64-bit BAR + ELSE + nip + THEN + F NOT AND \ Clear indicator bits + \ TODO: Use translate-address here! +; + +: map-out ( virt size -- ) + \ ." map-out called: " .s cr + 2drop +; + +: dma-alloc ( ... size -- virt ) + \ ." dma-alloc called: " .s cr + alloc-mem +; + +: dma-free ( virt size -- ) + \ ." dma-free called: " .s cr + free-mem +; + +: dma-map-in ( ... virt size cacheable? -- devaddr ) + \ ." dma-map-in called: " .s cr + 2drop +; + +: dma-map-out ( virt devaddr size -- ) + \ ." dma-map-out called: " .s cr + 2drop drop +; + +: dma-sync ( virt devaddr size -- ) + \ XXX should we add at least a memory barrier here? + \ ." dma-sync called: " .s cr + 2drop drop +; + +: open true ; +: close ; diff --git a/src/roms/SLOF/slof/fs/pci-device.fs b/src/roms/SLOF/slof/fs/pci-device.fs new file mode 100644 index 0000000..7b17758 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-device.fs @@ -0,0 +1,105 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +get-node CONSTANT my-phandle + +\ get the PUID from the node above +s" my-puid" my-phandle parent $call-static CONSTANT my-puid + +\ define the config reads +: config-b@ puid >r my-puid TO puid my-space + rtas-config-b@ r> TO puid ; +: config-w@ puid >r my-puid TO puid my-space + rtas-config-w@ r> TO puid ; +: config-l@ puid >r my-puid TO puid my-space + rtas-config-l@ r> TO puid ; + +\ define the config writes +: config-b! puid >r my-puid TO puid my-space + rtas-config-b! r> TO puid ; +: config-w! puid >r my-puid TO puid my-space + rtas-config-w! r> TO puid ; +: config-l! puid >r my-puid TO puid my-space + rtas-config-l! r> TO puid ; + +\ for Debug purposes: dumps the whole config space +: config-dump puid >r my-puid TO puid my-space pci-dump r> TO puid ; + +\ prepare the device for subsequent use +\ this word should be overloaded by the device file (if present) +\ the device file can call this file before implementing +\ its own open functionality +: open + puid >r \ save the old puid + my-puid TO puid \ set up the puid to the devices Hostbridge + pci-master-enable \ And enable Bus Master, IO and MEM access again. + pci-mem-enable \ enable mem access + pci-io-enable \ enable io access + r> TO puid \ restore puid + true +; + +\ close the previously opened device +\ this word should be overloaded by the device file (if present) +\ the device file can call this file after its implementation +\ of own close functionality +: close + puid >r \ save the old puid + my-puid TO puid \ set up the puid + pci-device-disable \ and disable the device + r> TO puid \ restore puid +; + +s" dma-function.fs" included + +\ generate the rom-fs filename from the vendor and device ID "pci-device_VENDORID_DEVICEID.fs" +: devicefile ( -- str len ) + s" pci-device_" + my-space pci-vendor@ 4 int2str $cat + s" _" $cat + my-space pci-device@ 4 int2str $cat + s" .fs" $cat +; + +\ generate the rom-fs filename from the base-class id "pci-class_BASECLASS.fs" +: classfile ( -- str len ) + s" pci-class_" + my-space pci-class@ 10 rshift 2 int2str $cat + s" .fs" $cat +; + +\ Set up the device with either default or special settings +: setup ( -- ) + \ is there special handling for this device, given vendor and device id? + devicefile romfs-lookup ?dup + IF + \ give it a special treatment + evaluate + ELSE + classfile romfs-lookup ?dup + IF + \ give it a pci-class related treatment + evaluate + ELSE + \ no special handling for this device, attempt autoconfiguration + my-space pci-class-name type 2a emit cr + my-space pci-device-generic-setup + THEN + THEN +; + +\ Disable Bus Master, Memory Space and I/O Space for this device +\ if Bus Master function is needed it should be enabled/disabled by open/close in the device driver code +pci-device-disable + +\ Enalbe #PERR and #SERR reporting +pci-error-enable + +\ Print out device information +my-space 44 pci-out \ config-addr ascii('D') + +\ and set up the device +setup diff --git a/src/roms/SLOF/slof/fs/pci-helper.fs b/src/roms/SLOF/slof/fs/pci-helper.fs new file mode 100644 index 0000000..a4f69f1 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-helper.fs @@ -0,0 +1,195 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ ---------------------------------------------------------- +\ **************** PCI Helper functions ******************* +\ ---------------------------------------------------------- + +\ convert an integer to string of len digits +: int2str ( int len -- str len ) swap s>d rot <# 0 ?DO # LOOP #> ; + +\ convert addr to busnr +: pci-addr2bus ( addr -- busnr ) 10 rshift FF and ; + +\ convert addr to devnr +: pci-addr2dev ( addr -- dev ) B rshift 1F and ; + +\ convert addr to functionnumber +: pci-addr2fn ( addr -- dev ) 8 rshift 7 and ; + +\ convert busnr devnr to addr +: pci-bus2addr ( busnr devnr -- addr ) B lshift swap 10 lshift + ; + +\ print out a pci config addr +: pci-addr-out ( addr -- ) dup pci-addr2bus 2 0.r space FFFF and 4 0.r ; + +\ Dump out the whole configspace +: pci-dump ( addr -- ) + 10 0 DO + dup + cr i 4 * + + dup pci-addr-out space + rtas-config-l@ 8 0.r + LOOP + drop cr +; + + +\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\ the following functions use l@ to fetch the data, +\ that's because the some pcie cores have probs with w@ +\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\ read Vendor ID +: pci-vendor@ ( addr -- id ) rtas-config-l@ FFFF and ; + +\ read Device ID +: pci-device@ ( addr -- id ) rtas-config-l@ 10 rshift ; + +\ read Status +: pci-status@ ( addr -- status ) 4 + rtas-config-l@ 10 rshift ; + +\ read Revision ID +: pci-revision@ ( addr -- id ) 8 + rtas-config-b@ ; + +\ read Class Code +: pci-class@ ( addr -- class ) 8 + rtas-config-l@ 8 rshift ; + +\ read Cache Line Size +: pci-cache@ ( addr -- size ) C + rtas-config-b@ ; + +\ read Header Type +: pci-htype@ ( addr -- type ) E + rtas-config-b@ ; + +\ read Sub Vendor ID +: pci-sub-vendor@ ( addr -- sub-id ) 2C + rtas-config-l@ FFFF and ; + +\ read Sub Device ID +: pci-sub-device@ ( addr -- sub-id ) 2C + rtas-config-l@ 10 rshift FFFF and ; + +\ read Interrupt Pin +: pci-interrupt@ ( addr -- interrupt ) 3D + rtas-config-b@ ; + +\ read Minimum Grant +: pci-min-grant@ ( addr -- min-gnt ) 3E + rtas-config-b@ ; + +\ read Maximum Latency +: pci-max-lat@ ( addr -- max-lat ) 3F + rtas-config-b@ ; + +\ Check if Capabilities are valid +: pci-capabilities? ( addr -- 0|1 ) pci-status@ 4 rshift 1 and ; + +\ fetch the offset of the next capability +: pci-cap-next ( cap-addr -- next-cap-off ) rtas-config-b@ FC and ; + +\ calc the address of the next capability +: pci-cap-next-addr ( cap-addr -- next-cap-addr ) 1+ dup pci-cap-next dup IF swap -100 and + ELSE nip THEN ; + + +\ Dump out all capabilities +: pci-cap-dump ( addr -- ) + cr + dup pci-capabilities? IF + 33 + BEGIN + pci-cap-next-addr dup 0<> + WHILE + dup pci-addr-out s" : " type + dup rtas-config-b@ 2 0.r cr + REPEAT + s" end found " + ELSE + s" capabilities not enabled!" + THEN + type cr drop +; + +\ search the capability-list for this id +: pci-cap-find ( addr id -- capp-addr|0 ) + swap dup pci-capabilities? IF + 33 + BEGIN + pci-cap-next-addr dup 0<> IF + dup rtas-config-b@ 2 pick = + ELSE + true + THEN + UNTIL + nip + ELSE + 2drop 0 + THEN +; + +\ check wether this device is a pci-express device +: pci-express? ( addr -- 0|1 ) 10 pci-cap-find 0<> ; + +\ check wether this device is a pci-express device +: pci-x? ( addr -- 0|1 ) 07 pci-cap-find 0<> ; + +\ check wether this device has extended config space +: pci-config-ext? ( addr -- 0|1 ) pci-express? ; + + +\ Disable Bus Master, Memory Space and I/O Space for this device +: pci-device-disable ( -- ) my-space 4 + dup rtas-config-l@ 7 invert and swap rtas-config-l! ; + +\ Enable Bus Master +: pci-master-enable ( -- ) my-space 4 + dup rtas-config-l@ 4 or swap rtas-config-l! ; + +\ Disable Bus Master +: pci-master-disable ( -- ) my-space 4 + dup rtas-config-l@ 4 invert and swap rtas-config-l! ; + +\ Enable response to mem accesses of pci device +: pci-mem-enable ( -- ) my-space 4 + dup rtas-config-w@ 2 or swap rtas-config-w! ; + +\ Enable response to I/O accesses of pci-device +: pci-io-enable ( -- ) my-space 4 + dup rtas-config-w@ 1 or swap rtas-config-w! ; + +\ Enable Bus Master, I/O and mem access +: pci-enable ( -- ) my-space 4 + dup rtas-config-w@ 7 or swap rtas-config-w! ; + +\ Enable #PERR and #SERR errors of pci-device +: pci-error-enable ( -- ) my-space 4 + dup rtas-config-w@ 140 or swap rtas-config-w! ; + +\ prints out the ScanInformation about a device +\ char is a sign for device type e.g. D - device ; B - bridge +: pci-out ( addr char -- ) + 15 spaces + over pci-addr-out + s" (" type emit s" ) : " type + dup pci-vendor@ 4 0.r space + pci-device@ 4 0.r + 4 spaces +; + + +\ set and fetch the interrupt Pin +: pci-irq-line@ ( addr -- irq-pin ) 3C + rtas-config-b@ ; +: pci-irq-line! ( pin addr -- ) 3C + rtas-config-b! ; + +\ set and fetch primary bus number +: pci-bus-prim! ( nr addr -- ) 18 + dup rtas-config-l@ FFFFFF00 and rot + swap rtas-config-l! ; +: pci-bus-prim@ ( addr -- nr ) 18 + rtas-config-l@ FF and ; + +\ set and fetch secondary bus number +: pci-bus-scnd! ( nr addr -- ) 18 + dup rtas-config-l@ FFFF00FF and rot 8 lshift + swap rtas-config-l! ; +: pci-bus-scnd@ ( addr -- nr ) 18 + rtas-config-l@ 8 rshift FF and ; + +\ set and fetch subordinate bus number +: pci-bus-subo! ( nr addr -- ) 18 + dup rtas-config-l@ FF00FFFF and rot 10 lshift + swap rtas-config-l! ; +: pci-bus-subo@ ( addr -- nr ) 18 + rtas-config-l@ 10 rshift FF and ; + +\ set and fetch primary, secondary and subordinate bus number +: pci-bus! ( subo scnd prim addr -- ) swap rot 8 lshift + rot 10 lshift + swap 18 + dup rtas-config-l@ FF000000 and rot + swap rtas-config-l! ; +: pci-bus@ ( addr -- subo scnd prim ) 18 + rtas-config-l@ dup 10 rshift FF and swap dup 8 rshift FF and swap FF and ; + +\ Reset secondary Status +: pci-reset-2nd ( addr -- ) 1C + dup rtas-config-l@ FFFF0000 or swap rtas-config-l! ; diff --git a/src/roms/SLOF/slof/fs/pci-properties.fs b/src/roms/SLOF/slof/fs/pci-properties.fs new file mode 100644 index 0000000..4f13402 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-properties.fs @@ -0,0 +1,668 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +#include "pci-class-code-names.fs" + +\ read the various bar type sizes +: pci-bar-size@ ( bar-addr -- bar-size ) -1 over rtas-config-l! rtas-config-l@ ; +: pci-bar-size-mem@ ( bar-addr -- mem-size ) pci-bar-size@ -10 and invert 1+ FFFFFFFF and ; +: pci-bar-size-io@ ( bar-addr -- io-size ) pci-bar-size@ -4 and invert 1+ FFFFFFFF and ; + +\ fetch raw bar size but keep original BAR value +: pci-bar-size ( bar-addr -- bar-size-raw ) + dup rtas-config-l@ swap \ fetch original Value ( bval baddr ) + -1 over rtas-config-l! \ make BAR show size ( bval baddr ) + dup rtas-config-l@ \ and fetch the size ( bval baddr bsize ) + -rot rtas-config-l! \ restore Value +; + +\ calc 32 bit MEM BAR size +: pci-bar-size-mem32 ( bar-addr -- bar-size ) + pci-bar-size \ fetch raw size + -10 and invert 1+ \ calc size + FFFFFFFF and \ keep lower 32 bits +; + +\ calc 32 bit ROM BAR size +: pci-bar-size-rom ( bar-addr -- bar-size ) + pci-bar-size \ fetch raw size + FFFFF800 and invert 1+ \ calc size + FFFFFFFF and \ keep lower 32 bits +; + +\ calc 64 bit MEM BAR size +: pci-bar-size-mem64 ( bar-addr -- bar-size ) + dup pci-bar-size \ fetch raw size lower 32 bits + swap 4 + pci-bar-size \ fetch raw size upper 32 bits + 20 lshift + \ and put them together + -10 and invert 1+ \ calc size +; + +\ calc IO BAR size +: pci-bar-size-io ( bar-addr -- bar-size ) + pci-bar-size \ fetch raw size + -4 and invert 1+ \ calc size + FFFFFFFF and \ keep lower 32 bits +; + + +\ decode the Bar Type +\ +----------------------------------------------------------------------------------------+ +\ | 3 2 1 0 | +\ | +----------------------------+-+--+-+ | +\ | MEM-BAR : | Base Address |P|TT|0| P - prefechtable ; TT - 00 : 32 Bit | +\ | +----------------------------+-+--+-+ 10 : 64 Bit | +\ | +-------------------------------+-+-+ | +\ | IO-BAR : | Base Address |0|1| | +\ | +-------------------------------+-+-+ | +\ | That is: 0 - no encoded BarType | +\ | 1 - IO - Bar | +\ | 2 - Memory 32 Bit | +\ | 3 - Memory 32 Bit prefetchable | +\ | 4 - Memory 64 Bit | +\ | 5 - Memory 64 Bit prefetchable | +\ +----------------------------------------------------------------------------------------+ +: pci-bar-code@ ( bar-addr -- 0|1..4|5 ) + rtas-config-l@ dup \ fetch the BaseAddressRegister + 1 and IF \ IO BAR ? + 2 and IF 0 ELSE 1 THEN \ only '01' is valid + ELSE \ Memory BAR ? + F and CASE + 0 OF 2 ENDOF \ Memory 32 Bit Non-Prefetchable + 8 OF 3 ENDOF \ Memory 32 Bit Prefetchable + 4 OF 4 ENDOF \ Memory 64 Bit Non-Prefetchable + C OF 5 ENDOF \ Memory 64 Bit Prefechtable + dup OF 0 ENDOF \ Not a valid BarType + ENDCASE + THEN +; + +\ *************************************************************************************** +\ Assigning the new Value to the BARs +\ *************************************************************************************** +\ align the current mem and set var to next mem +\ align with a size of 0 returns 0 !!! +: assign-var ( size var -- al-mem ) + 2dup @ \ ( size var size cur-mem ) read current free mem + swap #aligned \ ( size var al-mem ) align the mem to the size + dup 2swap -rot + \ ( al-mem var new-mem ) add size to aligned mem + swap ! \ ( al-mem ) set variable to new mem +; + +\ set bar to current free mem ( in variable ) and set variable to next free mem +: assign-bar-value32 ( bar size var -- 4 ) + over IF \ IF size > 0 + assign-var \ | ( bar al-mem ) set variable to next mem + swap rtas-config-l! \ | ( -- ) set the bar to al-mem + ELSE \ ELSE + 2drop drop \ | clear stack + THEN \ FI + 4 \ size of the base-address-register +; + +\ set bar to current free mem ( in variable ) and set variable to next free mem +: assign-bar-value64 ( bar size var -- 8 ) + over IF \ IF size > 0 + assign-var \ | ( bar al-mem ) set variable to next mem + swap \ | ( al-mem addr ) calc config-addr of this bar + 2dup rtas-config-l! \ | ( al-mem addr ) set the Lower part of the bar to al-mem + 4 + swap 20 rshift \ | ( al-mem>>32 addr ) prepare the upper part of the al-mem + swap rtas-config-l! \ | ( -- ) and set the upper part of the bar + ELSE \ ELSE + 2drop drop \ | clear stack + THEN \ FI + 8 \ size of the base-address-register +; + +\ Setup a prefetchable 64bit BAR and return its size +: assign-mem64-bar ( bar-addr -- 8 ) + dup pci-bar-size-mem64 \ fetch size + pci-next-mem64 @ 0 = IF \ Check if we have 64-bit memory range + pci-next-mem + ELSE + pci-next-mem64 + THEN + assign-bar-value64 \ and set it all +; + +\ Setup a prefetchable 32bit BAR and return its size +: assign-mem32-bar ( bar-addr -- 4 ) + dup pci-bar-size-mem32 \ fetch size + pci-next-mem \ var to change + assign-bar-value32 \ and set it all +; + +\ Setup a non-prefetchable 64bit BAR and return its size +: assign-mmio64-bar ( bar-addr -- 8 ) + dup pci-bar-size-mem64 \ fetch size + pci-next-mem64 @ 0 = IF \ Check if we have 64-bit memory range + pci-next-mmio + ELSE + pci-next-mem64 \ for board-qemu we will use same range + THEN + assign-bar-value64 \ and set it all +; + +\ Setup a non-prefetchable 32bit BAR and return its size +: assign-mmio32-bar ( bar-addr -- 4 ) + dup pci-bar-size-mem32 \ fetch size + pci-next-mmio \ var to change + assign-bar-value32 \ and set it all +; + +\ Setup an IO-Bar and return the size of the base-address-register +: assign-io-bar ( bar-addr -- 4 ) + dup pci-bar-size-io \ fetch size + pci-next-io \ var to change + assign-bar-value32 \ and set it all +; + +\ Setup an Expansion ROM bar +: assign-rom-bar ( bar-addr -- ) + dup pci-bar-size-rom \ fetch size + dup IF \ IF size > 0 + over >r \ | save bar addr for enable + pci-next-mmio \ | var to change + assign-bar-value32 \ | and set it + drop \ | forget the BAR length + r@ rtas-config-l@ \ | fetch BAR + 1 or r> rtas-config-l! \ | and enable the ROM + ELSE \ ELSE + 2drop \ | clear stack + THEN +; + +\ Setup the BAR due to its type and return the size of the register (4 or 8 Bytes ) used as increment for the BAR-Loop +: assign-bar ( bar-addr -- reg-size ) + dup pci-bar-code@ \ calc BAR type + dup IF \ IF >0 + CASE \ | CASE Setup the right type + 1 OF assign-io-bar ENDOF \ | - set up an IO-Bar + 2 OF assign-mmio32-bar ENDOF \ | - set up an 32bit MMIO-Bar + 3 OF assign-mem32-bar ENDOF \ | - set up an 32bit MEM-Bar (prefetchable) + 4 OF assign-mmio64-bar ENDOF \ | - set up an 64bit MMIO-Bar + 5 OF assign-mem64-bar ENDOF \ | - set up an 64bit MEM-Bar (prefetchable) + ENDCASE \ | ESAC + ELSE \ ELSE + ABORT \ | Throw an exception + THEN \ FI +; + +\ Setup all the bars of a pci device +: assign-all-device-bars ( configaddr -- ) + 28 10 DO \ BARs start at 10 and end at 27 + dup i + \ calc config-addr of the BAR + assign-bar \ and set it up + +LOOP \ add 4 or 8 to the index and loop + 30 + assign-rom-bar \ set up the ROM if available +; + +\ Setup all the bars of a pci device +: assign-all-bridge-bars ( configaddr -- ) + 18 10 DO \ BARs start at 10 and end at 17 + dup i + \ calc config-addr of the BAR + assign-bar \ and set it up + +LOOP \ add 4 or 8 to the index and loop + 38 + assign-rom-bar \ set up the ROM if available +; + +\ +---------------------------------------------------------------------------------------+ +\ | Numerical Representaton of a PCI address (PCI Bus Binding 2.2.1.1) | +\ | | +\ | 31 24 16 11 8 0 | +\ | +--------+--------+-----+---+--------+ | +\ | phys.hi: |npt000ss| bus | dev |fnc| reg | n - 0 relocatable | +\ | +--------+--------+-----+---+--------+ p - 1 prefetchable | +\ | t - 1 aliased or <1MB or <64KB | +\ | ss - 00 Configuration Space | +\ | 01 I/O Space | +\ | 10 Memory Space 32bits | +\ | 11 Memory Space 64bits | +\ +---------------------------------------------------------------------------------------+ + +\ *************************************************************************************** +\ Generating the assigned-addresses property +\ *************************************************************************************** +\ generate assigned-addresses property for 64Bit MEM-BAR and return BAR-reg-size +: gen-mem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 ) + dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size) + over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size) + 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val ) + 83000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 8 \ sizeof(BAR) = 8 Bytes +; + +\ generate assigned-addresses property for prefetchable 64Bit MEM-BAR and return BAR-reg-size +: gen-pmem64-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 8 ) + dup pci-bar-size-mem64 \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch lower 32 bits ( paddr plen baddr val.lo R: size) + over 4 + rtas-config-l@ \ | fetch upper 32 bits ( paddr plen baddr val.lo val.hi R: size) + 20 lshift + -10 and >r \ | calc 64 bit value and save it ( paddr plen baddr R: size val ) + C3000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 8 \ sizeof(BAR) = 8 Bytes +; + +\ generate assigned-addresses property for 32Bit MEM-BAR and return BAR-reg-size +: gen-mem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 ) + dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size) + -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val ) + 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ sizeof(BAR) = 4 Bytes +; + +\ generate assigned-addresses property for prefetchable 32Bit MEM-BAR and return BAR-reg-size +: gen-pmem32-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 ) + dup pci-bar-size-mem32 \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size) + -10 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val ) + C2000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ sizeof(BAR) = 4 Bytes +; + +\ generate assigned-addresses property for IO-BAR and return BAR-reg-size +: gen-io-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len 4 ) + dup pci-bar-size-io \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size) + -4 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val ) + 81000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ sizeof(BAR) = 4 Bytes +; + +\ generate assigned-addresses property for ROM-BAR +: gen-rom-bar-prop ( prop-addr prop-len bar-addr -- prop-addr prop-len ) + dup pci-bar-size-rom \ fetch BAR Size ( paddr plen baddr bsize ) + dup IF \ IF Size > 0 + >r dup rtas-config-l@ \ | save size and fetch value ( paddr plen baddr val R: size) + FFFFF800 and >r \ | calc 32 bit value and save it ( paddr plen baddr R: size val ) + 82000000 or encode-int+ \ | Encode config addr ( paddr plen R: size val ) + r> encode-64+ \ | Encode assigned addr ( paddr plen R: size ) + r> encode-64+ \ | Encode size ( paddr plen ) + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI +; + +\ add another BAR to the assigned addresses property and return the size of the encoded register +: pci-add-assigned-address ( prop-addr prop-len bar-addr -- prop-addr prop-len bsize ) + dup pci-bar-code@ \ calc BAR type ( paddr plen baddr btype) + CASE \ CASE for the BAR types ( paddr plen baddr ) + 0 OF drop 4 ENDOF \ - not a valid type so do nothing + 1 OF gen-io-bar-prop ENDOF \ - IO-BAR + 2 OF gen-mem32-bar-prop ENDOF \ - MEM32 + 3 OF gen-pmem32-bar-prop ENDOF \ - MEM32 prefetchable + 4 OF gen-mem64-bar-prop ENDOF \ - MEM64 + 5 OF gen-pmem64-bar-prop ENDOF \ - MEM64 prefetchable + ENDCASE \ ESAC ( paddr plen bsize ) +; + +\ generate the assigned address property for a PCI device +: pci-device-assigned-addresses-prop ( addr -- ) + encode-start \ provide mem for property ( addr paddr plen ) + 2 pick 30 + gen-rom-bar-prop \ assign the rom bar + 28 10 DO \ we have 6 possible BARs + 2 pick i + \ calc BAR address ( addr paddr plen bar-addr ) + pci-add-assigned-address \ and generate the props for the BAR + +LOOP \ increase Index by returned len + s" assigned-addresses" property drop \ and write it into the device tree +; + +\ generate the assigned address property for a PCI bridge +: pci-bridge-assigned-addresses-prop ( addr -- ) + encode-start \ provide mem for property + 2 pick 38 + gen-rom-bar-prop \ assign the rom bar + 18 10 DO \ we have 2 possible BARs + 2 pick i + \ ( addr paddr plen current-addr ) + pci-add-assigned-address \ and generate the props for the BAR + +LOOP \ increase Index by returned len + s" assigned-addresses" property drop \ and write it into the device tree +; + +\ check if the range is valid and if so encode it into +\ child.hi child.mid child.lo parent.hi parent.mid parent.lo size.hi size.lo +\ This is needed to translate the childrens addresses +\ We implement only 1:1 mapping for all PCI bridges +: pci-bridge-gen-range ( paddr plen base limit type -- paddr plen ) + >r over - \ calc size ( paddr plen base size R:type ) + dup 0< IF \ IF Size < 0 ( paddr plen base size R:type ) + 2drop r> drop \ | forget values ( paddr plen ) + ELSE \ ELSE + 1+ swap 2swap \ | adjust stack ( size base paddr plen R:type ) + r@ encode-int+ \ | Child type ( size base paddr plen R:type ) + 2 pick encode-64+ \ | Child address ( size base paddr plen R:type ) + r> encode-int+ \ | Parent type ( size base paddr plen ) + rot encode-64+ \ | Parent address ( size paddr plen ) + rot encode-64+ \ | Encode size ( paddr plen ) + THEN \ FI +; + + +\ generate an mmio space to the ranges property +: pci-bridge-gen-mmio-range ( addr prop-addr prop-len -- addr prop-addr prop-len ) + 2 pick 20 + rtas-config-l@ \ fetch Value ( addr paddr plen val ) + dup 0000FFF0 and 10 lshift \ calc base-address ( addr paddr plen val base ) + swap 000FFFFF or \ calc limit-address ( addr paddr plen base limit ) + 02000000 pci-bridge-gen-range \ and generate it ( addr paddr plen ) +; + +\ generate an mem space to the ranges property +: pci-bridge-gen-mem-range ( addr prop-addr prop-len -- addr prop-addr prop-len ) + 2 pick 24 + rtas-config-l@ \ fetch Value ( addr paddr plen val ) + dup 000FFFFF or \ calc limit Bits 31:0 ( addr paddr plen val limit.31:0 ) + swap 0000FFF0 and 10 lshift \ calc base Bits 31:0 ( addr paddr plen limit.31:0 base.31:0 ) + 4 pick 28 + rtas-config-l@ \ fetch upper Basebits ( addr paddr plen limit.31:0 base.31:0 base.63:32 ) + 20 lshift or swap \ and calc Base ( addr paddr plen base.63:0 limit.31:0 ) + 4 pick 2C + rtas-config-l@ \ fetch upper Limitbits ( addr paddr plen base.63:0 limit.31:0 limit.63:32 ) + 20 lshift or \ and calc Limit ( addr paddr plen base.63:0 limit.63:0 ) + 42000000 pci-bridge-gen-range \ and generate it ( addr paddr plen ) +; + +\ generate an io space to the ranges property +: pci-bridge-gen-io-range ( addr prop-addr prop-len -- addr prop-addr prop-len ) + 2 pick 1C + rtas-config-l@ \ fetch Value ( addr paddr plen val ) + dup 0000F000 and 00000FFF or \ calc Limit Bits 15:0 ( addr paddr plen val limit.15:0 ) + swap 000000F0 and 8 lshift \ calc Base Bits 15:0 ( addr paddr plen limit.15:0 base.15:0 ) + 4 pick 30 + rtas-config-l@ \ fetch upper Bits ( addr paddr plen limit.15:0 base.15:0 val ) + dup FFFF and 10 lshift rot or \ calc Base ( addr paddr plen limit.15:0 val base.31:0 ) + -rot FFFF0000 and or \ calc Limit ( addr paddr plen base.31:0 limit.31:0 ) + 01000000 pci-bridge-gen-range \ and generate it ( addr paddr plen ) +; + +\ generate the ranges property for a PCI bridge +: pci-bridge-range-props ( addr -- ) + encode-start \ provide mem for property + pci-bridge-gen-mmio-range \ generate the non prefetchable Memory Entry + pci-bridge-gen-mem-range \ generate the prefetchable Memory Entry + pci-bridge-gen-io-range \ generate the IO Entry + dup IF \ IF any space present (propsize>0) + s" ranges" property \ | write it into the device tree + ELSE \ ELSE + s" " s" ranges" property + 2drop \ | forget the properties + THEN \ FI + drop \ forget the address +; + +\ create the interrupt map for this bridge +: pci-bridge-interrupt-map ( -- ) + encode-start \ create the property ( paddr plen ) + get-node child \ find the first child ( paddr plen handle ) + BEGIN dup WHILE \ Loop as long as the handle is non-zero ( paddr plen handle ) + dup >r >space \ Get the my-space ( paddr plen addr R: handle ) + pci-gen-irq-entry \ and Encode the interrupt settings ( paddr plen R: handle) + r> peer \ Get neighbour ( paddr plen handle ) + REPEAT \ process next childe node ( paddr plen handle ) + drop \ forget the null ( paddr plen ) + s" interrupt-map" property \ and set it ( -- ) + 1 encode-int s" #interrupt-cells" property \ encode the cell# + f800 encode-int 0 encode-int+ 0 encode-int+ \ encode the bit mask for config addr (Dev only) + 7 encode-int+ s" interrupt-map-mask" property \ encode IRQ#=7 and generate property +; + +\ *************************************************************************************** +\ Generating the reg property +\ *************************************************************************************** +\ reg = config-addr 0 0 0 0 [BAR-config-addr 0 0 size.high size.low] + +\ encode the reg prop for a nonprefetchable 32bit MEM-BAR +: encode-mem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 ) + dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR ) + dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize ) + >r 02000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | encode size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ BAR-Len = 4 (32Bit) +; + +\ encode the reg prop for a prefetchable 32bit MEM-BAR +: encode-pmem32-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 4 ) + dup pci-bar-size-mem32 \ calc BAR-size ( not changing the BAR ) + dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize ) + >r 42000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | encode size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ BAR-Len = 4 (32Bit) +; + +\ encode the reg prop for a nonprefetchable 64bit MEM-BAR +: encode-mem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 ) + dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR ) + dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize ) + >r 03000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | encode size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 8 \ BAR-Len = 8 (64Bit) +; + +\ encode the reg prop for a prefetchable 64bit MEM-BAR +: encode-pmem64-bar ( prop-addr prop-len BAR-addr -- prop-addr prop-len 8 ) + dup pci-bar-size-mem64 \ calc BAR-size ( not changing the BAR ) + dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize ) + >r 43000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | encode size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 8 \ BAR-Len = 8 (64Bit) +; + +\ encode the reg prop for a ROM-BAR +: encode-rom-bar ( prop-addr prop-len configaddr -- prop-addr prop-len ) + dup pci-bar-size-rom \ fetch raw BAR-size + dup IF \ IF BAR is used + >r 02000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | calc and encode the size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI +; + +\ encode the reg prop for an IO-BAR +: encode-io-bar ( prop-addr prop-len BAR-addr BAR-value -- prop-addr prop-len 4 ) + dup pci-bar-size-io \ calc BAR-size ( not changing the BAR ) + dup IF \ IF BAR-size > 0 ( paddr plen baddr bsize ) + >r 01000000 or encode-int+ \ | save size and encode BAR addr + 0 encode-64+ \ | make mid and lo zero + r> encode-64+ \ | encode size + ELSE \ ELSE + 2drop \ | don't do anything + THEN \ FI + 4 \ BAR-Len = 4 (32Bit) +; + +\ write the representation of this BAR into the reg property +: encode-bar ( prop-addr prop-len bar-addr -- prop-addr prop-len bar-len ) + dup pci-bar-code@ \ calc BAR type + CASE \ CASE for the BAR types ( paddr plen baddr val ) + 0 OF drop 4 ENDOF \ - not a valid type so do nothing + 1 OF encode-io-bar ENDOF \ - IO-BAR + 2 OF encode-mem32-bar ENDOF \ - MEM32 + 3 OF encode-pmem32-bar ENDOF \ - MEM32 prefetchable + 4 OF encode-mem64-bar ENDOF \ - MEM64 + 5 OF encode-pmem64-bar ENDOF \ - MEM64 prefetchable + ENDCASE \ ESAC ( paddr plen blen ) +; + +\ Setup reg property +\ first encode the configuration space address +: pci-reg-props ( configaddr -- ) + dup encode-int \ configuration space ( caddr paddr plen ) + 0 encode-64+ \ make the rest 0 + 0 encode-64+ \ encode the size as 0 + 2 pick pci-htype@ \ fetch Header Type ( caddr paddr plen type ) + 1 and IF \ IF Bridge ( caddr paddr plen ) + 18 10 DO \ | loop over all BARs + 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr ) + encode-bar \ | encode this BAR ( caddr paddr plen blen ) + +LOOP \ | increase LoopIndex by the BARlen + 2 pick 38 + \ | calc ROM-BAR for a bridge ( caddr paddr plen baddr ) + encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen ) + ELSE \ ELSE ordinary device ( caddr paddr plen ) + 28 10 DO \ | loop over all BARs + 2 pick i + \ | calc bar-addr ( caddr paddr plen baddr ) + encode-bar \ | encode this BAR ( caddr paddr plen blen ) + +LOOP \ | increase LoopIndex by the BARlen + 2 pick 30 + \ | calc ROM-BAR for a device ( caddr paddr plen baddr ) + encode-rom-bar \ | encode the ROM-BAR ( caddr paddr plen ) + THEN \ FI ( caddr paddr plen ) + s" reg" property \ and store it into the property + drop +; + +\ *************************************************************************************** +\ Generating common properties +\ *************************************************************************************** +\ set up common properties for devices and bridges +: pci-common-props ( addr -- ) + dup pci-class-name device-name + dup pci-vendor@ encode-int s" vendor-id" property + dup pci-device@ encode-int s" device-id" property + dup pci-revision@ encode-int s" revision-id" property + dup pci-class@ encode-int s" class-code" property + 3 encode-int s" #address-cells" property + 2 encode-int s" #size-cells" property + + dup pci-config-ext? IF 1 encode-int s" ibm,pci-config-space-type" property THEN + + dup pci-status@ + dup 9 rshift 3 and encode-int s" devsel-speed" property + dup 7 rshift 1 and IF 0 0 s" fast-back-to-back" property THEN + dup 6 rshift 1 and IF 0 0 s" 66mhz-capable" property THEN + 5 rshift 1 and IF 0 0 s" udf-supported" property THEN + dup pci-cache@ ?dup IF encode-int s" cache-line-size" property THEN + pci-interrupt@ ?dup IF encode-int s" interrupts" property THEN +; + +\ set up device only properties +: pci-device-props ( addr -- ) + \ FIXME no s" compatible" prop + \ FIXME no s" alternate-reg" prop + \ FIXME no s" fcode-rom-offset" prop + \ FIXME no s" power-consumption" prop + dup pci-common-props + dup pci-min-grant@ encode-int s" min-grant" property + dup pci-max-lat@ encode-int s" max-latency" property + dup pci-sub-device@ ?dup IF encode-int s" subsystem-id" property THEN + dup pci-sub-vendor@ ?dup IF encode-int s" subsystem-vendor-id" property THEN + dup pci-device-assigned-addresses-prop + pci-reg-props + pci-hotplug-enabled IF + \ QEMU uses static assignments for my-drc-index: + \ 40000000h + $bus << 8 + $slot << 3 + dup dup pci-addr2bus 8 lshift + swap pci-addr2dev 3 lshift or + 40000000 + encode-int s" ibm,my-drc-index" property + \ QEMU uses "Slot $bus*32$slotno" for loc-code + dup dup pci-addr2bus 20 * + swap pci-addr2dev + + a base ! + s" Slot " rot $cathex + hex + encode-string s" ibm,loc-code" property + THEN +; + +\ set up bridge only properties +: pci-bridge-props ( addr -- ) + \ FIXME no s" slot-names" prop + \ FIXME no s" bus-master-capable" prop + \ FIXME no s" clock-frequency" prop + dup pci-bus@ + encode-int s" primary-bus" property + encode-int s" secondary-bus" property + encode-int s" subordinate-bus" property + dup pci-bus@ drop encode-int rot encode-int+ s" bus-range" property + pci-device-slots encode-int s" slot-names" property + dup pci-bridge-range-props + dup pci-bridge-assigned-addresses-prop + \ Only create interrupt-map when it doesn't already exist + \ (it can be provided by qemu) + s" interrupt-map" get-node get-property IF + pci-bridge-interrupt-map + ELSE 2drop THEN + pci-reg-props +; + + +\ used to set up all unknown Bridges. +\ If a Bridge has no special handling for setup +\ the device file (pci-bridge_VENDOR_DEVICE.fs) can call +\ this word to setup busses and scan beyond. +: pci-bridge-generic-setup ( addr -- ) + pci-device-slots >r \ save the slot array on return stack + dup pci-common-props \ set the common properties before scanning the bus + s" pci" device-type \ the type is allways "pci" + dup pci-bridge-probe \ find all device connected to it + dup assign-all-bridge-bars \ set up all memory access BARs + dup pci-set-irq-line \ set the interrupt pin + dup pci-set-capabilities \ set up the capabilities + pci-bridge-props \ and generate all properties + r> TO pci-device-slots \ and reset the slot array +; + +DEFER func-pci-device-props + +\ used for an gerneric device set up +\ if a device has no special handling for setup +\ the device file (pci-device_VENDOR_DEVICE.fs) can call +\ this word to setup the device +: pci-device-generic-setup ( config-addr -- ) + dup assign-all-device-bars \ calc all BARs + dup pci-set-irq-line \ set the interrupt pin + dup pci-set-capabilities \ set up the capabilities + dup func-pci-device-props \ and generate all properties + drop \ forget the config-addr +; + +' pci-device-props TO func-pci-device-props diff --git a/src/roms/SLOF/slof/fs/pci-scan.fs b/src/roms/SLOF/slof/fs/pci-scan.fs new file mode 100644 index 0000000..2fdf0e8 --- /dev/null +++ b/src/roms/SLOF/slof/fs/pci-scan.fs @@ -0,0 +1,351 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ ---------------------------------------------------------- +\ ********** Variables to be set by host bridge ********** +\ ---------------------------------------------------------- + +\ Values of the next free memory area +VARIABLE pci-next-mem \ prefetchable memory mapped +VARIABLE pci-max-mem +VARIABLE pci-next-mmio \ non-prefetchable memory +VARIABLE pci-max-mmio +VARIABLE pci-next-io \ I/O space +VARIABLE pci-max-io +VARIABLE pci-next-mem64 \ prefetchable 64-bit memory mapped +VARIABLE pci-max-mem64 + +\ Counter of busses found +0 VALUE pci-bus-number +\ Counter of devices found +0 VALUE pci-device-number +\ bit field of devices plugged into this bridge +0 VALUE pci-device-slots +\ byte field holding the device-slot number vector of the current device +\ the vector can be as deep as the max depth of bridges possible +\ 3,4,5 means +\ the 5th slot on the bus of the bridge in +\ the 4th slot on the bus of the bridge in +\ the 3rd slot on the HostBridge bus +here 100 allot CONSTANT pci-device-vec +0 VALUE pci-device-vec-len +\ enable/disable creation of hotplug-specific properties +0 VALUE pci-hotplug-enabled + + +\ Fixme Glue to the pci-devices ... remove this later +: next-pci-mem ( addr -- addr ) pci-next-mem ; +: next-pci-mmio ( addr -- addr ) pci-next-mmio ; +: next-pci-io ( addr -- addr ) pci-next-io ; + + +#include "pci-helper.fs" + +\ Dump out the pci device-slot vector +: pci-vec ( -- ) + cr s" device-vec(" type + pci-device-vec-len dup 2 0.r s" ):" type + 1+ 0 DO + pci-device-vec i + c@ + space 2 0.r + LOOP + cr +; + +\ prints out all relevant pci variables +: pci-var-out ( -- ) + s" mem:" type pci-next-mem @ 16 0.r cr + s" mmio:" type pci-next-mmio @ 16 0.r cr + s" io:" type pci-next-io @ 16 0.r cr +; + + +\ Update the device-slot number vector +\ Set the bit of the DeviceSlot in the Slot array +: pci-set-slot ( addr -- ) + pci-addr2dev dup \ calc slot number + pci-device-vec-len \ the end of the vector + pci-device-vec + c! \ and update the vector + 80000000 swap rshift \ calc bit position of the device slot + pci-device-slots or \ set this bit + TO pci-device-slots \ and write it back +; + +\ Update pci-next-mmio to be 1MB aligned and set the mmio-base register +\ and set the Limit register to the maximum available address space +\ needed for scanning possible devices behind the bridge +: pci-bridge-set-mmio-base ( addr -- ) + pci-next-mmio @ 100000 #aligned \ read the current Value and align to 1MB boundary + dup 100000 + pci-next-mmio ! \ and write back with 1MB for bridge + 10 rshift \ mmio-base reg is only the upper 16 bits + pci-max-mmio @ 1- FFFF0000 and or \ and Insert mmio Limit (set it to max) + swap 20 + rtas-config-l! \ and write it into the bridge +; + +\ Update pci-next-mmio to be 1MB aligned and set the mmio-limit register +\ The Limit Value is one less then the upper boundary +\ If the limit is less than the base the mmio is disabled +: pci-bridge-set-mmio-limit ( addr -- ) + pci-next-mmio @ 100000 #aligned \ fetch current value and align to 1MB + dup pci-next-mmio ! \ and write it back + 1- FFFF0000 and \ make it one less and keep upper 16 bits + over 20 + rtas-config-l@ 0000FFFF and \ fetch original value + or swap 20 + rtas-config-l! \ and write it into the Reg +; + +\ Update pci-next-mem to be 1MB aligned and set the mem-base and mem-base-upper register +\ and set the Limit register to the maximum available address space +\ needed for scanning possible devices behind the bridge +: pci-bridge-set-mem-base ( addr -- ) + pci-next-mem @ 100000 #aligned \ read the current Value and align to 1MB boundary + dup 100000 + pci-next-mem ! \ and write back with 1MB for bridge + over 24 + rtas-config-w@ \ check if 64bit support + 1 and IF \ IF 64 bit support + pci-next-mem64 @ 100000000 #aligned \ | read the current Value of 64-bit and align to 4GB boundary + dup 100000000 + pci-next-mem64 x! \ | and write back with 1GB for bridge + 2 pick swap \ | + 20 rshift \ | keep upper 32 bits + swap 28 + rtas-config-l! \ | and write it into the Base-Upper32-bits + pci-max-mem64 @ 20 rshift \ | fetch max Limit address and keep upper 32 bits + 2 pick 2C + rtas-config-l! \ | and set the Limit + THEN \ FI + 10 rshift \ keep upper 16 bits + pci-max-mem @ 1- FFFF0000 and or \ and Insert mmem Limit (set it to max) + swap 24 + rtas-config-l! \ and write it into the bridge +; + +\ Update pci-next-mem to be 1MB aligned and set the mem-limit register +\ The Limit Value is one less then the upper boundary +\ If the limit is less than the base the mem is disabled +: pci-bridge-set-mem-limit ( addr -- ) + pci-next-mem @ 100000 #aligned \ read the current Value and align to 1MB boundary + dup pci-next-mem ! \ and write it back + 1- \ make limit one less than boundary + over 24 + rtas-config-w@ \ check if 64bit support + 1 and IF \ IF 64 bit support + pci-next-mem64 @ 100000000 #aligned \ | Reat current value of 64-bar and align at 4GB + dup pci-next-mem64 x! \ | and write it back + 1- \ | make limite one less than boundary + 2 pick swap \ | + 20 rshift \ | keep upper 32 bits + swap 2C + rtas-config-l! \ | and write it into the Limit-Upper32-bits + THEN \ FI + FFFF0000 and \ keep upper 16 bits + over 24 + rtas-config-l@ 0000FFFF and \ fetch original Value + or swap 24 + rtas-config-l! \ and write it into the bridge +; + +\ Update pci-next-io to be 4KB aligned and set the io-base and io-base-upper register +\ and set the Limit register to the maximum available address space +\ needed for scanning possible devices behind the bridge +: pci-bridge-set-io-base ( addr -- ) + pci-next-io @ 1000 #aligned \ read the current Value and align to 4KB boundary + dup 1000 + pci-next-io ! \ and write back with 4K for bridge + over 1C + rtas-config-l@ \ check if 32bit support + 1 and IF \ IF 32 bit support + 2dup 10 rshift \ | keep upper 16 bits + pci-max-io @ FFFF0000 and or \ | insert upper 16 bits of Max-Limit + swap 30 + rtas-config-l! \ | and write it into the Base-Upper16-bits + THEN \ FI + 8 rshift 000000FF and \ keep upper 8 bits + pci-max-io @ 1- 0000FF00 and or \ insert upper 8 bits of Max-Limit + over rtas-config-l@ FFFF0000 and \ fetch original Value + or swap 1C + rtas-config-l! \ and write it into the bridge +; + +\ Update pci-next-io to be 4KB aligned and set the io-limit register +\ The Limit Value is one less then the upper boundary +\ If the limit is less than the base the io is disabled +: pci-bridge-set-io-limit ( addr -- ) + pci-next-io @ 1000 #aligned \ read the current Value and align to 4KB boundary + dup pci-next-io ! \ and write it back + 1- \ make limit one less than boundary + over 1D + rtas-config-b@ \ check if 32bit support + 1 and IF \ IF 32 bit support + 2dup FFFF0000 and \ | keep upper 16 bits + over 30 + rtas-config-l@ \ | fetch original Value + or swap 30 + rtas-config-l! \ | and write it into the Limit-Upper16-bits + THEN \ FI + 0000FF00 and \ keep upper 8 bits + over 1C + rtas-config-l@ FFFF00FF and \ fetch original Value + or swap 1C + rtas-config-l! \ and write it into the bridge +; + +\ set up all base registers to the current variable Values +: pci-bridge-set-bases ( addr -- ) + dup pci-bridge-set-mmio-base + dup pci-bridge-set-mem-base + pci-bridge-set-io-base +; + +\ set up all limit registers to the current variable Values +: pci-bridge-set-limits ( addr -- ) + dup pci-bridge-set-mmio-limit + dup pci-bridge-set-mem-limit + pci-bridge-set-io-limit +; + +\ ---------------------------------------------------------- +\ ****************** PCI Scan functions ****************** +\ ---------------------------------------------------------- + +\ define function pointer as forward declaration of pci-probe-bus +DEFER func-pci-probe-bus +DEFER func-pci-bridge-range-props + +\ Setup the Base and Limits in the Bridge +\ and scan the bus(es) beyond that Bridge +: pci-bridge-probe ( addr -- ) + dup pci-bridge-set-bases \ SetUp all Base Registers + dup func-pci-bridge-range-props \ Setup temporary "range + pci-bus-number 1+ TO pci-bus-number \ increase number of busses found + pci-device-vec-len 1+ TO pci-device-vec-len \ increase the device-slot vector depth + dup \ stack config-addr for pci-bus! + FF swap \ Subordinate Bus Number ( for now to max to open all subbusses ) + pci-bus-number swap \ Secondary Bus Number ( the new busnumber ) + dup pci-addr2bus swap \ Primary Bus Number ( the current bus ) + pci-bus! \ and set them into the bridge + pci-enable \ enable mem/IO transactions + dup pci-bus-scnd@ func-pci-probe-bus \ and probe the secondary bus + dup pci-bus-number swap pci-bus-subo! \ set SubOrdinate Bus Number to current number of busses + pci-device-vec-len 1- TO pci-device-vec-len \ decrease the device-slot vector depth + dup pci-bridge-set-limits \ SetUp all Limit Registers + drop \ forget the config-addr +; + +\ set up the pci-device +: pci-device-setup ( addr -- ) + drop \ since the config-addr is coded in my-space, drop it here + s" pci-device.fs" included \ and setup the device as node in the device tree +; + +\ set up the pci bridge +: pci-bridge-setup ( addr -- ) + drop \ since the config-addr is coded in my-space, drop it here + s" pci-bridge.fs" included \ and setup the bridge as node in the device tree +; + +\ add the new found device/bridge to the device tree and set it up +: pci-add-device ( addr -- ) + new-device \ create a new device-tree node + dup set-space \ set the config addr for this device tree entry + dup pci-set-slot \ set the slot bit + dup pci-htype@ \ read HEADER-Type + 7f and \ Mask bit 7 - multifunction device + CASE + 0 OF pci-device-setup ENDOF \ | set up the device + 1 OF pci-bridge-setup ENDOF \ | set up the bridge + dup OF dup pci-htype@ pci-out ENDOF + ENDCASE + finish-device \ and close the device-tree node +; + +\ check for multifunction and for each function +\ (dependig from header type) call device or bridge setup +: pci-setup-device ( addr -- ) + dup pci-htype@ \ read HEADER-Type + 80 and IF 8 ELSE 1 THEN \ check for multifunction + 0 DO \ LOOP over all possible functions (either 8 or only 1) + dup + i 8 lshift + \ calc device-function-config-addr + dup pci-vendor@ \ check if valid function + FFFF = IF + drop \ non-valid so forget the address + ELSE + pci-device-number 1+ \ increase the number of devices + TO pci-device-number \ and store it + pci-add-device \ and add the device to the device tree and set it up + THEN + LOOP \ next function + drop \ forget the device-addr +; + +\ check if a device is plugged into this bus at this device number +: pci-probe-device ( busnr devicenr -- ) + pci-bus2addr \ calc pci-address + dup pci-vendor@ \ fetch Vendor-ID + FFFF = IF \ check if valid + drop \ if not forget it + ELSE + pci-setup-device \ if valid setup the device + THEN +; + +\ walk through all 32 possible pci devices on this bus and probe them +: pci-probe-bus ( busnr -- ) + 0 TO pci-device-slots \ reset slot array to unpoppulated + 20 0 DO + dup + i pci-probe-device + LOOP + drop +; + +\ setup the function pointer used in pci-bridge-setup +' pci-probe-bus TO func-pci-probe-bus + +\ ---------------------------------------------------------- +\ ****************** System functions ******************** +\ ---------------------------------------------------------- +\ Setup the whole system for pci devices +\ start with the bus-min and try all busses +\ until at least 1 device was found +\ ( needed for HostBridges that don't start with Bus 0 ) +: pci-probe-all ( bus-max bus-min -- ) \ Check all busses from bus-min up to bus-max if needed + 0 TO pci-device-vec-len \ reset the device-slot vector + DO + i TO pci-bus-number \ set current Busnumber + 0 TO pci-device-number \ reset Device Number + pci-bus-number pci-probe-bus \ and probe this bus + pci-device-number 0 > IF LEAVE THEN \ if we found a device we're done + LOOP \ else next bus +; + +: (probe-pci-host-bridge) ( bus-max bus-min -- ) + 0d emit ." Adapters on " puid 10 0.r cr \ print the puid we're looking at + ( bus-max bus-min ) pci-probe-all \ and walk the bus + pci-device-number 0= IF \ IF no devices found + 15 spaces \ | indent the output + ." None" cr \ | tell the world our result + THEN \ FI +; + +\ probe the hostbridge that is specified in my-puid +\ for the mmio mem and io addresses: +\ base is the least available address +\ max is the highest available address +: probe-pci-host-bridge ( bus-max bus-min mmio-max mmio-base mem-max mem-base io-max io-base my-puid -- ) + puid >r TO puid \ save puid and set the new + pci-next-io ! \ save the next io-base address + pci-max-io ! \ save the max io-space address + pci-next-mem ! \ save the next mem-base address + pci-max-mem ! \ save the max mem-space address + pci-next-mmio ! \ save the next mmio-base address + pci-max-mmio ! \ save the max mmio-space address + (probe-pci-host-bridge) + r> TO puid \ restore puid +; + +\ provide the device-alias definition words +#include <pci-aliases.fs> + +\ provide all words for the interrupts settings +#include <pci-interrupts.fs> + +\ provide all words for the pci capabilities init +#include <pci-capabilities.fs> + +\ provide all words needed to generate the properties and/or assign BAR values +#include "pci-properties.fs" + +\ setup the function pointer for bridge ranges +' pci-bridge-range-props TO func-pci-bridge-range-props diff --git a/src/roms/SLOF/slof/fs/preprocessor.fs b/src/roms/SLOF/slof/fs/preprocessor.fs new file mode 100644 index 0000000..a13fb30 --- /dev/null +++ b/src/roms/SLOF/slof/fs/preprocessor.fs @@ -0,0 +1,41 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: ([IF]) + BEGIN + BEGIN parse-word dup 0= WHILE + 2drop refill + REPEAT + + 2dup s" [IF]" str= IF 1 throw THEN + 2dup s" [ELSE]" str= IF 2 throw THEN + 2dup s" [THEN]" str= IF 3 throw THEN + s" \" str= IF linefeed parse 2drop THEN + AGAIN + ; + +: [IF] ( flag -- ) + IF exit THEN + 1 BEGIN + ['] ([IF]) catch + CASE + 1 OF 1+ ENDOF + 2 OF dup 1 = if 1- then ENDOF + 3 OF 1- ENDOF + ENDCASE + dup 0 <= + UNTIL drop +; immediate + +: [ELSE] 0 [COMPILE] [IF] ; immediate +: [THEN] ; immediate + diff --git a/src/roms/SLOF/slof/fs/property.fs b/src/roms/SLOF/slof/fs/property.fs new file mode 100644 index 0000000..cb99fbe --- /dev/null +++ b/src/roms/SLOF/slof/fs/property.fs @@ -0,0 +1,192 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Properties 5.3.5 + +\ Words on the property list for a node are actually executable words, +\ that return the address and length of the property's data. Special +\ nodes like /options can have their properties use specialized code to +\ dynamically generate their data; most nodes just use a 2CONSTANT. + +\ Put the type as byte before the property +\ { int = 1, bytes = 2, string = 3 } +\ This is used by .properties for pretty print + +\ Flag for type encoding, encode-* resets, set-property set the flag +true value encode-first? + +: decode-int over >r 4 /string r> 4c@ swap 2swap swap bljoin ; +: decode-64 decode-int -rot decode-int -rot 2swap swap lxjoin ; +: decode-string ( prop-addr1 prop-len1 -- prop-addr2 prop-len2 str len ) + dup 0= IF 2dup EXIT THEN \ string properties with zero length + over BEGIN dup c@ 0= IF 1+ -rot swap 2 pick over - rot over - -rot 1- + EXIT THEN 1+ AGAIN ; + +\ Remove a word from a wordlist. +: (prune) ( name len head -- ) + dup >r (find) ?dup IF r> BEGIN dup @ WHILE 2dup @ = IF + >r @ r> ! EXIT THEN @ REPEAT 2drop ELSE r> drop THEN ; +: prune ( name len -- ) last (prune) ; + +: set-property ( data dlen name nlen phandle -- ) + true to encode-first? + get-current >r node>properties @ set-current + 2dup prune $2CONSTANT r> set-current ; +: delete-property ( name nlen -- ) + get-node get-current >r node>properties @ set-current + prune r> set-current ; +: property ( data dlen name nlen -- ) get-node set-property ; +: get-property ( str len phandle -- true | data dlen false ) + ?dup 0= IF cr cr cr ." get-property for " type ." on zero phandle" + cr cr true EXIT THEN + node>properties @ voc-find dup IF link> execute false ELSE drop true THEN ; +: get-package-property ( str len phandle -- true | data dlen false ) + get-property ; +: get-my-property ( str len -- true | data dlen false ) + my-self ihandle>phandle get-property ; +: get-parent-property ( str len -- true | data dlen false ) + my-parent ihandle>phandle get-property ; + +: get-inherited-property ( str len -- true | data dlen false ) + my-self ihandle>phandle + BEGIN + 3dup get-property 0= IF + \ Property found + rot drop rot drop rot drop false EXIT + THEN + parent dup 0= IF + \ Root node has been reached, but property has not been found + 3drop true EXIT + THEN + AGAIN +; + +\ Print out properties. + +20 CONSTANT indent-prop + +: .prop-int ( str len -- ) + space + 400 min 0 + ?DO + i over + dup ( str act-addr act-addr ) + c@ 2 0.r 1+ dup c@ 2 0.r 1+ dup c@ 2 0.r 1+ c@ 2 0.r ( str ) + i c and c = IF \ check for multipleof 16 bytes + cr indent @ indent-prop + 1+ 0 \ linefeed + indent + DO + space \ print spaces + LOOP + ELSE + space space \ print two spaces + THEN + 4 +LOOP + drop +; + +: .prop-bytes ( str len -- ) + 2dup -4 and .prop-int ( str len ) + + dup 3 and dup IF ( str len len%4 ) + >r -4 and + r> ( str' len%4 ) + bounds ( str' str'+len%4 ) + DO + i c@ 2 0.r \ Print last 3 bytes + LOOP + ELSE + 3drop + THEN +; + +: .prop-string ( str len ) + 2dup space type + cr indent @ indent-prop + 0 DO space LOOP \ Linefeed + .prop-bytes +; + +: .propbytes ( xt -- ) + execute dup + IF + over cell- @ execute + ELSE + 2drop + THEN +; +: .property ( lfa -- ) + cr indent @ 0 + ?DO + space + LOOP + link> dup >name name>string 2dup type nip ( len ) + indent-prop swap - ( xt 20-len ) + dup 0< IF drop 0 THEN 0 ( xt number-of-space 0 ) + ?DO + space + LOOP + .propbytes +; +: (.properties) ( phandle -- ) + node>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ; +: .properties ( -- ) + get-node (.properties) ; + +: next-property ( str len phandle -- false | str' len' true ) + ?dup 0= IF device-tree @ THEN \ XXX: is this line required? + node>properties @ + >r 2dup 0= swap 0= or IF 2drop r> cell+ ELSE r> voc-find THEN + @ dup IF link>name name>string true THEN ; + + +\ encode-* words and all helpers + +\ Start a encoded property string +: encode-start ( -- prop 0 ) + ['] .prop-int compile, + false to encode-first? + here 0 +; + +: encode-int ( val -- prop prop-len ) + encode-first? IF + ['] .prop-int compile, \ Execution token for print + false to encode-first? + THEN + here swap lbsplit c, c, c, c, /l +; +: encode-bytes ( str len -- prop-addr prop-len ) + encode-first? IF + ['] .prop-bytes compile, \ Execution token for print + false to encode-first? + THEN + here over 2dup 2>r allot swap move 2r> +; +: encode-string ( str len -- prop-addr prop-len ) + encode-first? IF + ['] .prop-string compile, \ Execution token for print + false to encode-first? + THEN + encode-bytes 0 c, char+ +; + +: encode+ ( prop1-addr prop1-len prop2-addr prop2-len -- prop-addr prop-len ) + nip + ; +: encode-int+ encode-int encode+ ; +: encode-64 xlsplit encode-int rot encode-int+ ; +: encode-64+ encode-64 encode+ ; + + +\ Helpers for common nodes. Should perhaps remove "compatible", as it's +\ not typically a single string. +: device-name encode-string s" name" property ; +: device-type encode-string s" device_type" property ; +: model encode-string s" model" property ; +: compatible encode-string s" compatible" property ; diff --git a/src/roms/SLOF/slof/fs/quiesce.fs b/src/roms/SLOF/slof/fs/quiesce.fs new file mode 100644 index 0000000..47006e4 --- /dev/null +++ b/src/roms/SLOF/slof/fs/quiesce.fs @@ -0,0 +1,58 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +100 CONSTANT quiesce-xt# + +\ The array with the quiesce execution tokens: +CREATE quiesce-xts quiesce-xt# cells allot +quiesce-xts quiesce-xt# cells erase + +0 VALUE quiesce-done? + + +\ Add a token to the quiesce execution token array: +: add-quiesce-xt ( xt -- ) + quiesce-xt# 0 DO + quiesce-xts I cells + ( xt arrayptr ) + dup @ 0= ( xt arrayptr true|false ) + IF + ! UNLOOP EXIT + ELSE ( xt arrayptr ) + over swap ( xt xt arrayptr ) + @ = \ xt already stored ? + IF + drop UNLOOP EXIT + THEN ( xt ) + THEN + LOOP + drop ( xt -- ) + ." Warning: quiesce xt list is full." cr +; + + +\ The quiesce call asserts that the firmware and all hardware +\ is in a sane state (e.g. assert that no background DMA is +\ running anymore) +: quiesce ( -- ) + quiesce-done? IF EXIT THEN + true to quiesce-done? + quiesce-xt# 0 DO + quiesce-xts I cells + ( arrayptr ) + @ dup IF ( xt ) + EXECUTE + ELSE + drop UNLOOP EXIT + THEN + LOOP +; + diff --git a/src/roms/SLOF/slof/fs/romfs.fs b/src/roms/SLOF/slof/fs/romfs.fs new file mode 100644 index 0000000..7d7e463 --- /dev/null +++ b/src/roms/SLOF/slof/fs/romfs.fs @@ -0,0 +1,123 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +STRUCT + cell field romfs>file-header + cell field romfs>data + cell field romfs>data-size + cell field romfs>flags + +CONSTANT /romfs-lookup-control-block + +CREATE romfs-lookup-cb /romfs-lookup-control-block allot +romfs-lookup-cb /romfs-lookup-control-block erase + +: create-filename ( string -- string\0 ) + here >r dup 8 + allot + r@ over 8 + erase + r@ zplace r> ; + +: romfs-lookup ( fn-str fn-len -- data size | false ) + create-filename romfs-base + romfs-lookup-cb romfs-lookup-entry call-c + 0= IF romfs-lookup-cb dup romfs>data @ swap romfs>data-size @ ELSE + false THEN ; + +: ibm,romfs-lookup ( fn-str fn-len -- data-high data-low size | 0 0 false ) + romfs-lookup dup + 0= if drop 0 0 false else + swap dup 20 rshift swap ffffffff and then ; + +\ FIXME For a short time ... +: romfs-lookup-client ibm,romfs-lookup ; + +\ Fixme temp implementation + +STRUCT + cell field romfs>next-off + cell field romfs>size + cell field romfs>flags + cell field romfs>data-off + cell field romfs>name + +CONSTANT /romfs-cb + +: romfs-map-file ( fn-str fn-len -- file-addr file-size ) + romfs-base >r + BEGIN 2dup r@ romfs>name zcount string=ci not WHILE + ( fn-str fn-len ) ( R: rom-cb-file-addr ) + r> romfs>next-off dup @ dup 0= IF 1 THROW THEN + >r REPEAT + ( fn-str fn-len ) ( R: rom-cb-file-addr ) + 2drop r@ romfs>data-off @ r@ + r> romfs>size @ ; + +\ returns address of romfs-header file +: flash-header ( -- address | false ) + get-flash-base 28 + \ prepare flash header file address + dup rx@ \ fetch "magic123" + 6d61676963313233 <> IF \ IF flash is not valid + drop \ | forget address + false \ | return false + THEN \ FI +; + +CREATE bdate-str 10 allot +: bdate2human ( -- addr len ) + flash-header 40 + rx@ (.) + drop dup 0 + bdate-str 6 + 4 move + dup 4 + bdate-str 0 + 2 move + dup 6 + bdate-str 3 + 2 move + dup 8 + bdate-str b + 2 move + a + bdate-str e + 2 move + 2d bdate-str 2 + c! + 2d bdate-str 5 + c! + 20 bdate-str a + c! + 3a bdate-str d + c! + bdate-str 10 +; + + +\ Look up a file in the ROM file system and evaluate it + +: included ( fn fn-len -- ) + 2dup >r >r romfs-lookup dup IF + r> drop r> drop evaluate + ELSE + drop ." Cannot open file : " r> r> type cr + THEN +; + +: include ( " fn " -- ) + parse-word included +; + +: ?include ( flag " fn " -- ) + parse-word rot IF included ELSE 2drop THEN +; + +: include? ( nargs flag " fn " -- ) + parse-word rot IF + rot drop included + ELSE + 2drop 0 ?DO drop LOOP + THEN +; + + +\ List files in ROMfs + +: (print-romfs-file-info) ( file-addr -- ) + 9 emit dup b 0.r 2 spaces dup 8 + @ 6 0.r 2 spaces 20 + zcount type cr +; + +: romfs-list ( -- ) + romfs-base 0 cr BEGIN + dup (print-romfs-file-info) dup @ dup 0= UNTIL 2drop +; diff --git a/src/roms/SLOF/slof/fs/root.fs b/src/roms/SLOF/slof/fs/root.fs new file mode 100644 index 0000000..21c7109 --- /dev/null +++ b/src/roms/SLOF/slof/fs/root.fs @@ -0,0 +1,84 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ this creates the root and common branches of the device tree + +defer (client-exec) +defer client-exec + +\ defined in slof/fs/client.fs +defer callback +defer continue-client + +0 VALUE chosen-node + +: chosen + chosen-node dup 0= IF + drop s" /chosen" find-node dup to chosen-node + THEN +; + +: set-chosen ( prop len name len -- ) + chosen set-property ; + +: get-chosen ( name len -- [ prop len ] success ) + chosen get-property 0= ; + +\ Look for an exising root, create one if needed +" /" find-node dup 0= IF + drop + new-device + s" /" device-name +ELSE + extend-device +THEN + +\ Create /chosen if it doesn't exist +" /chosen" find-node dup 0= IF + drop + new-device + s" chosen" device-name + s" " encode-string s" bootargs" property + s" " encode-string s" bootpath" property + finish-device +ELSE + drop +THEN + +\ Create /aliases +new-device + s" aliases" device-name +finish-device + +\ Create /options +new-device + s" options" device-name +finish-device + +\ Create /openprom +new-device + s" openprom" device-name + 0 0 s" relative-addressing" property +finish-device + +\ Create /packages +new-device +#include <packages.fs> +finish-device + +: open true ; +: close ; +#include <archsupport.fs> + +\ Finish root +finish-device + diff --git a/src/roms/SLOF/slof/fs/rtas/rtas-cpu.fs b/src/roms/SLOF/slof/fs/rtas/rtas-cpu.fs new file mode 100644 index 0000000..c133abc --- /dev/null +++ b/src/roms/SLOF/slof/fs/rtas/rtas-cpu.fs @@ -0,0 +1,23 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: rtas-start-cpu ( pid loc r3 -- status ) + [ s" start-cpu" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 3 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args2 l! + rtas-cb rtas>args1 l! + rtas-cb rtas>args0 l! + 0 rtas-cb rtas>args3 l! + enter-rtas + rtas-cb rtas>args3 l@ +; diff --git a/src/roms/SLOF/slof/fs/rtas/rtas-flash.fs b/src/roms/SLOF/slof/fs/rtas/rtas-flash.fs new file mode 100644 index 0000000..f8abeaa --- /dev/null +++ b/src/roms/SLOF/slof/fs/rtas/rtas-flash.fs @@ -0,0 +1,46 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: rtas-ibm-update-flash-64-and-reboot ( block-list -- status ) + [ s" ibm,update-flash-64-and-reboot" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 1 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args1 l@ +; + +: rtas-ibm-manage-flash-image ( image-to-commit -- status ) + [ s" ibm,manage-flash-image" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 1 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args1 l@ +; + +: rtas-set-flashside ( flashside -- status ) + [ s" rtas-set-flashside" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 1 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args1 l@ +; + +: rtas-get-flashside ( -- status ) + [ s" rtas-get-flashside" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 0 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + enter-rtas + rtas-cb rtas>args0 l@ +; diff --git a/src/roms/SLOF/slof/fs/rtas/rtas-init.fs b/src/roms/SLOF/slof/fs/rtas/rtas-init.fs new file mode 100644 index 0000000..8451cfd --- /dev/null +++ b/src/roms/SLOF/slof/fs/rtas/rtas-init.fs @@ -0,0 +1,121 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ (rtas-size) determines the size required for RTAS. +\ It looks at the rtas binary in the flash and reads the rtas-size from +\ its header at offset 8. +: (rtas-size) ( -- rtas-size ) + s" rtas" romfs-lookup dup 0= + ABORT" romfs-lookup for rtas failed" + drop 8 + @ +; + +(rtas-size) CONSTANT rtas-size + +: instantiate-rtas ( adr -- entry ) + dup rtas-size erase + s" rtas" romfs-lookup 0= + ABORT" romfs-lookup for rtas failed" + rtas-config swap start-rtas ; + +here fff + fffffffffffff000 and here - allot +here rtas-size allot CONSTANT rtas-start-addr + +rtas-start-addr instantiate-rtas CONSTANT rtas-entry-point + +: drone-rtas + rtas-start-addr + dup rtas-size erase + 2000000 start-rtas to rtas-entry-point +; + + +\ ffffffffffffffff CONSTANT rtas-entry-point + +\ rtas control block + +STRUCT + /l field rtas>token + /l field rtas>nargs + /l field rtas>nret + /l field rtas>args0 + /l field rtas>args1 + /l field rtas>args2 + /l field rtas>args3 + /l field rtas>args4 + /l field rtas>args5 + /l field rtas>args6 + /l field rtas>args7 + /l C * field rtas>args + /l field rtas>bla + +CONSTANT /rtas-control-block + +CREATE rtas-cb /rtas-control-block allot +rtas-cb /rtas-control-block erase + +\ call-c ( p0 p1 p2 entry -- ret ) + +: enter-rtas ( -- ) + rtas-cb rtas-start-addr 0 rtas-entry-point call-c drop ; + + +\ This is the structure of the RTAS function jump table in the C code: +STRUCT + cell FIELD rtasfunctab>name + cell FIELD rtasfunctab>func + cell FIELD rtasfunctab>flags +CONSTANT rtasfunctab-size + +\ Create RTAS token properties by analyzing the jump table in the C code: +: rtas-create-token-properties ( -- ) + rtas-start-addr 10 + @ rtas-start-addr + \ Get pointer to jump table + rtas-start-addr 18 + @ rtas-start-addr + l@ \ Get the number of entries + 0 DO + dup rtasfunctab>func @ 0<> \ function pointer must not be NULL + over rtasfunctab>flags @ 1 and 0= \ Check the only-internal flag + and + IF + i 1+ encode-int \ Create the token value + 2 pick rtasfunctab>name @ zcount \ Create the token name string + property \ Create the property + THEN + rtasfunctab-size + \ Proceed to the next entry + LOOP + drop +; + +\ Get the RTAS token that corresponds to an RTAS property name: +: rtas-get-token ( str len -- token|0 ) + rtas-start-addr 10 + @ rtas-start-addr + \ Get pointer to jump table + rtas-start-addr 18 + @ rtas-start-addr + l@ \ Get the number of entries + 0 DO + dup rtasfunctab>name @ \ Get pointer to function name + dup 0<> \ function name must not be NULL + over zcount 5 pick = nip and \ Check if both strings have same length + IF + 3 pick 3 pick \ Make a copy of the token name string + comp 0= + IF + drop 2drop + i 1+ \ If the name matched, return the token + UNLOOP EXIT + THEN + ELSE + drop + THEN + rtasfunctab-size + \ Proceed to the next entry + LOOP + drop + ." RTAS token not found: " type cr + 0 +; diff --git a/src/roms/SLOF/slof/fs/rtas/rtas-reboot.fs b/src/roms/SLOF/slof/fs/rtas/rtas-reboot.fs new file mode 100644 index 0000000..a9539ec --- /dev/null +++ b/src/roms/SLOF/slof/fs/rtas/rtas-reboot.fs @@ -0,0 +1,33 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: rtas-power-off ( x y -- status ) + [ s" power-off" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 2 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args0 l! + rtas-cb rtas>args1 l! + enter-rtas + rtas-cb rtas>args2 l@ +; + +: power-off ( -- ) 0 0 rtas-power-off ; + + +: rtas-system-reboot ( -- status ) + [ s" system-reboot" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 0 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args1 l@ +; diff --git a/src/roms/SLOF/slof/fs/rtas/rtas-vpd.fs b/src/roms/SLOF/slof/fs/rtas/rtas-vpd.fs new file mode 100644 index 0000000..7fb4b54 --- /dev/null +++ b/src/roms/SLOF/slof/fs/rtas/rtas-vpd.fs @@ -0,0 +1,33 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: rtas-read-vpd ( offset length data -- status ) + [ s" msg-read-vpd" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 3 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args2 l! + rtas-cb rtas>args1 l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args3 l@ +; + +: rtas-write-vpd ( offset length data -- status ) + [ s" msg-write-vpd" rtas-get-token ] LITERAL rtas-cb rtas>token l! + 3 rtas-cb rtas>nargs l! + 1 rtas-cb rtas>nret l! + rtas-cb rtas>args2 l! + rtas-cb rtas>args1 l! + rtas-cb rtas>args0 l! + enter-rtas + rtas-cb rtas>args3 l@ +; diff --git a/src/roms/SLOF/slof/fs/scsi-disk.fs b/src/roms/SLOF/slof/fs/scsi-disk.fs new file mode 100644 index 0000000..1978471 --- /dev/null +++ b/src/roms/SLOF/slof/fs/scsi-disk.fs @@ -0,0 +1,324 @@ +\ ***************************************************************************** +\ * Copyright (c) 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Create new VSCSI child device + +\ Create device +new-device + +\ Set name +s" disk" device-name + +s" block" device-type + +false VALUE scsi-disk-debug? + +\ Get SCSI bits +scsi-open + +\ Send SCSI commands to controller + +: execute-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len -- ... ) + ( ... [ sense-buf sense-len ] stat ) + " execute-scsi-command" $call-parent +; + +: retry-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len #retries -- ... ) + ( ... 0 | [ sense-buf sense-len ] stat ) + " retry-scsi-command" $call-parent +; + +\ ---------------------------------\ +\ Common SCSI Commands and helpers \ +\ ---------------------------------\ + +0 INSTANCE VALUE block-size +0 INSTANCE VALUE max-transfer +0 INSTANCE VALUE max-block-num +0 INSTANCE VALUE is_cdrom +INSTANCE VARIABLE deblocker + +\ This scratch area is made global for now as we only +\ use it for small temporary commands such as inquiry +\ read-capacity or media events +CREATE scratch 100 allot +CREATE cdb 10 allot + +: dump-scsi-error ( sense-buf sense-len stat name namelen -- ) + ." SCSI-DISK: " my-self instance>path type ." ," type ." failed" cr + ." SCSI-DISK: Status " dup . .status-text + 0<> IF + ." Sense " scsi-get-sense-data dup . .sense-text + ." ASC " . ." ASCQ " . cr + ELSE drop THEN +; + +: read-blocks ( addr block# #blocks -- #read ) + scsi-disk-debug? IF + ." SCSI-DISK: read-blocks " .s cr + THEN + + \ Bound check. This should probably be done by deblocker + \ but it doesn't at this point so do it here + 2dup + max-block-num > IF + ." SCSI-DISK: Access beyond end of device ! " cr + drop + dup max-block-num > IF + drop drop 0 EXIT + THEN + dup max-block-num swap - + THEN + + dup block-size * ( addr block# #blocks len ) + >r rot r> ( block# #blocks addr len ) + 2swap ( addr len block# #blocks ) + dup >r + cdb scsi-build-read-10 ( addr len ) + r> -rot ( #blocks addr len ) + scsi-dir-read cdb scsi-param-size 10 + retry-scsi-command + ( #blocks [ sense-buf sense-len ] stat ) + dup 0<> IF " read-blocks" dump-scsi-error -65 throw ELSE drop THEN +; + +: (inquiry) ( size -- buffer | NULL ) + dup cdb scsi-build-inquiry + \ 16 retries for inquiry to flush out any UAs + scratch swap scsi-dir-read cdb scsi-param-size 10 retry-scsi-command + \ Success ? + 0= IF scratch ELSE 2drop 0 THEN +; + +: inquiry ( -- buffer | NULL ) + scsi-disk-debug? IF + ." SCSI-DISK: inquiry " .s cr + THEN + d# 36 (inquiry) 0= IF 0 EXIT THEN + scratch inquiry-data>add-length c@ 5 + + (inquiry) +; + +: read-capacity ( -- blocksize #blocks ) + \ Now issue the read-capacity command + scsi-disk-debug? IF + ." SCSI-DISK: read-capacity " .s cr + THEN + \ Make sure that there are zeros in the buffer in case something goes wrong: + scratch 10 erase + cdb scsi-build-read-cap-10 scratch scsi-length-read-cap-10-data scsi-dir-read + cdb scsi-param-size 1 retry-scsi-command + \ Success ? + dup 0<> IF " read-capacity" dump-scsi-error 0 0 EXIT THEN + drop scratch scsi-get-capacity-10 1 + +; + +100 CONSTANT test-unit-retries + +\ SCSI test-unit-read +: test-unit-ready ( true | [ ascq asc sense-key false ] ) + scsi-disk-debug? IF + ." SCSI-DISK: test-unit-ready " .s cr + THEN + cdb scsi-build-test-unit-ready + 0 0 0 cdb scsi-param-size test-unit-retries retry-scsi-command + \ stat == 0, return + 0= IF true EXIT THEN + \ check sense len, no sense -> return HW error + 0= IF drop 0 0 4 false EXIT THEN + \ get sense + scsi-get-sense-data false +; + + +: start-stop-unit ( state# -- true | false ) + scsi-disk-debug? IF + ." SCSI-DISK: start-stop-unit " .s cr + THEN + cdb scsi-build-start-stop-unit + 0 0 0 cdb scsi-param-size 10 retry-scsi-command + \ Success ? + 0= IF true ELSE 2drop false THEN +; + +: compare-sense ( ascq asc key ascq2 asc2 key2 -- true | false ) + 3 pick = ( ascq asc key ascq2 asc2 keycmp ) + swap 4 pick = ( ascq asc key ascq2 keycmp asccmp ) + rot 5 pick = ( ascq asc key keycmp asccmp ascqcmp ) + and and nip nip nip +; + +\ -------------------------\ +\ CDROM specific functions \ +\ -------------------------\ + +0 CONSTANT CDROM-READY +1 CONSTANT CDROM-NOT-READY +2 CONSTANT CDROM-NO-DISK +3 CONSTANT CDROM-TRAY-OPEN +4 CONSTANT CDROM-INIT-REQUIRED +5 CONSTANT CDROM-TRAY-MAYBE-OPEN + +: cdrom-try-close-tray ( -- ) + scsi-const-load start-stop-unit drop +; + +: cdrom-must-close-tray ( -- ) + scsi-const-load start-stop-unit not IF + ." Tray open !" cr -65 throw + THEN +; + +: get-media-event ( -- true | false ) + scsi-disk-debug? IF + ." SCSI-DISK: get-media-event " .s cr + THEN + cdb scsi-build-get-media-event + scratch scsi-length-media-event scsi-dir-read cdb scsi-param-size 1 retry-scsi-command + \ Success ? + 0= IF true ELSE 2drop false THEN +; + +: cdrom-status ( -- status ) + test-unit-ready + IF CDROM-READY EXIT THEN + + scsi-disk-debug? IF + ." TestUnitReady sense: " 3dup . . . cr + THEN + + 3dup 1 4 2 compare-sense IF + 3drop CDROM-NOT-READY EXIT + THEN + + get-media-event IF + scratch w@ 4 >= IF + scratch 2 + c@ 04 = IF + scratch 5 + c@ + dup 02 and 0<> IF drop 3drop CDROM-READY EXIT THEN + dup 01 and 0<> IF drop 3drop CDROM-TRAY-OPEN EXIT THEN + drop 3drop CDROM-NO-DISK EXIT + THEN + THEN + THEN + + 3dup 2 4 2 compare-sense IF + 3drop CDROM-INIT-REQUIRED EXIT + THEN + over 4 = over 2 = and IF + \ Format in progress... what do we do ? Just ignore + 3drop CDROM-READY EXIT + THEN + over 3a = IF + 3drop CDROM-NO-DISK EXIT + THEN + + \ Other error... + 3drop CDROM-TRAY-MAYBE-OPEN +; + +: prep-cdrom ( -- ready? ) + 5 0 DO + cdrom-status CASE + CDROM-READY OF UNLOOP true EXIT ENDOF + CDROM-NO-DISK OF ." No medium !" cr UNLOOP false EXIT ENDOF + CDROM-TRAY-OPEN OF cdrom-must-close-tray ENDOF + CDROM-INIT-REQUIRED OF cdrom-try-close-tray ENDOF + CDROM-TRAY-MAYBE-OPEN OF cdrom-try-close-tray ENDOF + ENDCASE + d# 1000 ms + LOOP + ." Drive not ready !" cr false +; + +\ ------------------------\ +\ Disk specific functions \ +\ ------------------------\ + +: prep-disk ( -- ready? ) + test-unit-ready not IF + ." SCSI-DISK: Disk not ready ! " + ." Sense " dup .sense-text ." [" . ." ]" + ." ASC " . ." ASCQ " . cr + false EXIT THEN true +; + +\ --------------------------\ +\ Standard device interface \ +\ --------------------------\ + +: open ( -- true | false ) + scsi-disk-debug? IF + ." SCSI-DISK: open [" .s ." ] unit is " my-unit . . ." [" .s ." ]" cr + THEN + my-unit " set-address" $call-parent + + inquiry dup 0= IF drop false EXIT THEN + scsi-disk-debug? IF + ." ---- inquiry: ----" cr + dup 100 dump cr + ." ------------------" cr + THEN + + \ Skip devices with PQ != 0 + dup inquiry-data>peripheral c@ e0 and 0 <> IF + ." SCSI-DISK: Unsupported PQ != 0" cr + false EXIT + THEN + + inquiry-data>peripheral c@ CASE + 5 OF true to is_cdrom ENDOF + 7 OF true to is_cdrom ENDOF + ENDCASE + + scsi-disk-debug? IF + is_cdrom IF + ." SCSI-DISK: device treated as CD-ROM" cr + ELSE + ." SCSI-DISK: device treated as disk" cr + THEN + THEN + + is_cdrom IF prep-cdrom ELSE prep-disk THEN + not IF false EXIT THEN + + " max-transfer" $call-parent to max-transfer + + read-capacity to max-block-num to block-size + max-block-num 0= block-size 0= OR IF + ." SCSI-DISK: Failed to get disk capacity!" cr + FALSE EXIT + THEN + + scsi-disk-debug? IF + ." Capacity: " max-block-num . ." blocks of " block-size . cr + THEN + + 0 0 " deblocker" $open-package dup deblocker ! dup IF + " disk-label" find-package IF + my-args rot interpose + THEN + THEN 0<> +; + +: close ( -- ) + deblocker @ close-package ; + +: seek ( pos.lo pos.hi -- status ) + s" seek" deblocker @ $call-method ; + +: read ( addr len -- actual ) + s" read" deblocker @ $call-method ; + +\ Get rid of SCSI bits +scsi-close + +finish-device diff --git a/src/roms/SLOF/slof/fs/scsi-host-helpers.fs b/src/roms/SLOF/slof/fs/scsi-host-helpers.fs new file mode 100644 index 0000000..579ce37 --- /dev/null +++ b/src/roms/SLOF/slof/fs/scsi-host-helpers.fs @@ -0,0 +1,127 @@ +\ This file is meant to be included by SCSI hosts to provide +\ helpers such as retry-scsi-command + +\ Returns 1 for retry, 0 for return with no error and +\ -1 for return with an error +\ +: check-retry-sense? ( sense-buf sense-len -- retry? ) + \ Check if the sense-len is at least 8 bytes + 8 < IF -1 EXIT THEN + + \ Fixed sense record, look for filemark etc... + dup sense-data>response-code c@ 7e and 70 = IF + dup sense-data>sense-key c@ e0 and IF drop -1 EXIT THEN + THEN + + \ Get sense data + scsi-get-sense-data? IF ( ascq asc sense-key ) + \ No sense or recoverable, return success + dup 2 < IF 3drop 0 EXIT THEN + \ not ready and unit attention, retry + dup 2 = swap 6 = or nip nip IF 1 EXIT THEN + THEN + \ Return failure + -1 +; + +\ This is almost as the standard retry-command but returns +\ additionally the length of the returned sense information +\ +\ The hw-err? field is gone, stat is -1 for a HW error, and +\ the sense data is provided iff stat is CHECK_CONDITION (02) +\ +\ Additionally we wait 10ms between retries +\ +0 INSTANCE VALUE rcmd-buf-addr +0 INSTANCE VALUE rcmd-buf-len +0 INSTANCE VALUE rcmd-dir +0 INSTANCE VALUE rcmd-cmd-addr +0 INSTANCE VALUE rcmd-cmd-len + +: retry-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len #retries -- ... ) + ( ... 0 | [ sense-buf sense-len ] stat ) + >r \ stash #retries + to rcmd-cmd-len to rcmd-cmd-addr to rcmd-dir to rcmd-buf-len to rcmd-buf-addr + 0 \ dummy status & sense + r> \ retreive #retries ( stat #retries ) + 0 DO + \ drop previous status & sense + 0<> IF 2drop THEN + + \ Restore arguments + rcmd-buf-addr + rcmd-buf-len + rcmd-dir + rcmd-cmd-addr + rcmd-cmd-len + + \ Send command + execute-scsi-command ( [ sense-buf sense-len ] stat ) + + \ Success ? + dup 0= IF LEAVE THEN + + \ HW error ? + dup -1 = IF LEAVE THEN + + \ Check condition ? + dup 2 = IF ( sense-buf sense-len stat ) + >r \ stash stat ( sense-buf sense len ) + 2dup + check-retry-sense? ( sense-buf sense-len retry? ) + r> swap \ unstash stat ( sense-buf sense-len stat retry? ) + \ Check retry? result + CASE + 0 OF 3drop 0 LEAVE ENDOF \ Swallow error, return 0 + -1 OF LEAVE ENDOF \ No retry + ENDCASE + ELSE \ Anything other than busy -> exit + dup 8 <> IF LEAVE THEN + THEN + a ms + LOOP +; + +\ ----------------------------------------------------------- +\ Some command helpers +\ ----------------------------------------------------------- +\ +\ TODO: Get rid of global "sector" and instead return an +\ allocated block for the caller to free + +CREATE sector d# 512 allot +CREATE cdb 10 allot + +: (inquiry) ( size -- buffer | NULL ) + dup cdb scsi-build-inquiry + \ 16 retries for inquiry to flush out any UAs + sector swap scsi-dir-read cdb scsi-param-size 10 retry-scsi-command + \ Success ? + 0= IF sector ELSE 2drop 0 THEN +; + +\ Read the initial 36bytes and then decide how much more is to be read +: inquiry ( -- buffer | NULL ) + d# 36 (inquiry) 0= IF 0 EXIT THEN + sector inquiry-data>add-length c@ 5 + + (inquiry) +; + +: report-luns ( -- [ sector ] true | false ) + 200 cdb scsi-build-report-luns + \ 16 retries to flush out any UAs + sector 200 scsi-dir-read cdb scsi-param-size 10 retry-scsi-command + \ Success ? + 0= IF sector true ELSE drop false THEN +; + +\ This routine creates a disk alias for the first found disk/cdrom +: make-disk-alias ( $name srplun -- ) + >r 2dup r> -rot ( $name srplun $name) + find-alias 0<> IF 4drop exit THEN + get-node node>path + 20 allot + " /disk@" string-cat ( $name srplun npath npathl ) + rot base @ >r hex (u.) r> base ! string-cat ( $name $diskpath ) + set-alias +; diff --git a/src/roms/SLOF/slof/fs/scsi-loader.fs b/src/roms/SLOF/slof/fs/scsi-loader.fs new file mode 100644 index 0000000..fec1f78 --- /dev/null +++ b/src/roms/SLOF/slof/fs/scsi-loader.fs @@ -0,0 +1,77 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ ************************************** +\ Last change: MiR 13.11.2007 10:55:57 +\ ************************************** + +: .ansi-attr-off 1b emit ." [0m" ; \ ESC Sequence: all terminal attributes off +: .ansi-blue 1b emit ." [34m" ; \ ESC Sequence: foreground-color = blue +: .ansi-green 1b emit ." [32m" ; \ ESC Sequence: foreground-color = green +: .ansi-red 1b emit ." [31m" ; \ ESC Sequence: foreground-color = green +: .ansi-bold 1b emit ." [1m" ; \ ESC Sequence: foreground-color bold + +false VALUE scsi-supp-present? + +: scsi-xt-err ." SCSI-ERROR (Intern) " ; +' scsi-xt-err VALUE scsi-open-xt \ preset with an invalid token + +\ ************************************* +\ utility to show all active word-lists +\ ************************************* +: .wordlists ( -- ) + .ansi-red + get-order ( -- wid1 .. widn n ) + dup space 28 emit .d ." word lists : " + 0 DO + . 08 emit 2c emit + LOOP + 08 emit \ 'bs' + 29 emit \ ')' + cr space 28 emit + ." Context: " context dup . + @ 5b emit . 8 emit 5d emit + space + ." / Current: " current . + .ansi-attr-off + cr +; + +\ ************************************* +\ utility to show first word-lists +\ ************************************* +: .context ( num -- ) + .ansi-red + space + 5b emit + 23 emit . 3a emit + context @ + . 8 emit 5d emit space + .ansi-attr-off +; + +\ **************************************************************************** +\ open scsi-support by adding a new word list on top of search path +\ first check if scsi-support.fs must be included (first call) +\ when open use execution pointer to access version in new word list +\ **************************************************************************** +: scsi-open ( -- ) + scsi-supp-present? NOT + IF + s" scsi-support.fs" included ( xt-open ) + to scsi-open-xt ( ) + true to scsi-supp-present? + THEN + scsi-open-xt execute +; + + diff --git a/src/roms/SLOF/slof/fs/scsi-probe-helpers.fs b/src/roms/SLOF/slof/fs/scsi-probe-helpers.fs new file mode 100644 index 0000000..6aec8b1 --- /dev/null +++ b/src/roms/SLOF/slof/fs/scsi-probe-helpers.fs @@ -0,0 +1,95 @@ +\ This file is meant to be included by SCSI hosts to provide +\ probing helpers - scsi-find-disks + +: wrapped-inquiry ( -- true | false ) + inquiry 0= IF false EXIT THEN + \ Skip devices with PQ != 0 + sector inquiry-data>peripheral c@ e0 and 0 = +; + +: scsi-read-lun ( addr -- lun true | false ) + dup c@ C0 AND CASE + 40 OF w@-be 3FFF AND TRUE ENDOF + 0 OF w@-be TRUE ENDOF + dup dup OF ." Unsupported LUN format = " . cr FALSE ENDOF + ENDCASE +; + +: vscsi-report-luns ( -- array ndev ) + \ array of pointers, up to 8 devices + dev-max-target 3 << alloc-mem dup + 0 ( devarray devcur ndev ) + dev-max-target 0 DO + i 0 dev-generate-srplun (set-target) + report-luns nip IF + sector l@ ( devarray devcur ndev size ) + sector 8 + swap ( devarray devcur ndev lunarray size ) + dup 8 + dup alloc-mem ( devarray devcur ndev lunarray size size+ mem ) + dup rot 0 fill ( devarray devcur ndev lunarray size mem ) + dup >r swap move r> ( devarray devcur ndev mem ) + dup sector l@ 3 >> 0 ?DO ( devarray devcur ndev mem memcur ) + dup dup scsi-read-lun IF + j swap dev-generate-srplun swap x! 8 + + ELSE + 2drop + THEN + LOOP drop + rot ( devarray ndev mem devcur ) + dup >r x! r> 8 + ( devarray ndev devcur ) + swap 1 + + ELSE + dev-max-target 1 = IF + \ Some USB MSC devices do not implement report + \ luns. That will stall the bulk pipe. These devices are + \ single lun devices, report it accordingly + + ( devarray devcur ndev ) + 16 alloc-mem ( devarray devcur ndev mem ) + dup 16 0 fill ( devarray devcur ndev mem ) + dup 0 0 dev-generate-srplun swap x! ( devarray devcur ndev mem ) + rot x! ( devarray ndev ) + 1 + + UNLOOP EXIT + THEN + THEN + LOOP + nip +; + +: make-media-alias ( $name srplun -- ) + >r + get-next-alias ?dup IF + r> make-disk-alias + ELSE + r> drop + THEN +; + +: scsi-find-disks ( -- ) + ." SCSI: Looking for devices" cr + vscsi-report-luns + 0 ?DO + dup x@ + BEGIN + dup x@ + dup 0= IF drop TRUE ELSE + (set-target) wrapped-inquiry IF + ." " current-target (u.) type ." " + \ XXX FIXME: Check top bits to ignore unsupported units + \ and maybe provide better printout & more cases + \ XXX FIXME: Actually check for LUNs + sector inquiry-data>peripheral c@ CASE + 0 OF ." DISK : " " disk" current-target make-media-alias ENDOF + 5 OF ." CD-ROM : " " cdrom" current-target make-media-alias ENDOF + 7 OF ." OPTICAL : " " cdrom" current-target make-media-alias ENDOF + e OF ." RED-BLOCK: " " disk" current-target make-media-alias ENDOF + dup dup OF ." ? (" . 8 emit 29 emit 5 spaces ENDOF + ENDCASE + sector .inquiry-text cr + THEN + 8 + FALSE + THEN + UNTIL drop + 8 + + LOOP drop +; diff --git a/src/roms/SLOF/slof/fs/scsi-support.fs b/src/roms/SLOF/slof/fs/scsi-support.fs new file mode 100644 index 0000000..3e65c87 --- /dev/null +++ b/src/roms/SLOF/slof/fs/scsi-support.fs @@ -0,0 +1,847 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ ************************************************ +\ create a new scsi word-list named 'scsi-words' +\ ************************************************ +vocabulary scsi-words \ create new word list named 'scsi-words' +also scsi-words definitions \ place next definitions into new list + +\ for some commands specific parameters are used, which normally +\ need not to be altered. These values are preset at include time +\ or explicit by a call of 'scsi-supp-init' +false value scsi-param-debug \ common debugging flag +d# 0 value scsi-param-size \ length of CDB processed last +h# 0 value scsi-param-control \ control word for CDBs as defined in SAM-4 +d# 0 value scsi-param-errors \ counter for detected errors + +\ utility to increment error counter +: scsi-inc-errors + scsi-param-errors 1 + to scsi-param-errors +; + +\ *************************************************************************** +\ SCSI-Command: TEST UNIT READY +\ Type: Primary Command (SPC-3 clause 6.33) +\ *************************************************************************** +\ Forth Word: scsi-build-test-unit-ready ( cdb -- ) +\ *************************************************************************** +\ checks if a device is ready to receive commands +\ *************************************************************************** +\ command code: +00 CONSTANT scsi-cmd-test-unit-ready +\ CDB structure: +STRUCT + /c FIELD test-unit-ready>operation-code \ 00h + 4 FIELD test-unit-ready>reserved \ unused + /c FIELD test-unit-ready>control \ control byte as specified in SAM-4 +CONSTANT scsi-length-test-unit-ready + +\ cdb build: +\ all fields are zeroed +: scsi-build-test-unit-ready ( cdb -- ) + dup scsi-length-test-unit-ready erase ( cdb ) + scsi-param-control swap test-unit-ready>control c! ( ) + scsi-length-test-unit-ready to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: REPORT LUNS +\ Type: Primary Command +\ *************************************************************************** +\ Forth Word: scsi-build-report-luns ( cdb -- ) +\ *************************************************************************** +\ report all LUNs supported by a device +\ *************************************************************************** +\ command code: +a0 CONSTANT scsi-cmd-report-luns +\ CDB structure: +STRUCT + /c FIELD report-luns>operation-code \ a0h + 1 FIELD report-luns>reserved \ unused + /c FIELD report-luns>select-report \ report select byte + 3 FIELD report-luns>reserved2 \ unused + /l FIELD report-luns>alloc-length \ report length + 1 FIELD report-luns>reserved3 \ unused + /c FIELD report-luns>control \ control byte +CONSTANT scsi-length-report-luns + +\ cdb build: +\ all fields are zeroed +: scsi-build-report-luns ( alloc-len cdb -- ) + dup scsi-length-report-luns erase \ 12 bytes CDB + scsi-cmd-report-luns over ( alloc-len cdb cmd cdb ) + report-luns>operation-code c! ( alloc-len cdb ) + scsi-param-control over report-luns>control c! ( alloc-len cdb ) + report-luns>alloc-length l! \ size of Data-In Buffer + scsi-length-report-luns to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: REQUEST SENSE +\ Type: Primary Command (SPC-3 clause 6.27) +\ *************************************************************************** +\ Forth Word: scsi-build-request-sense ( cdb -- ) +\ *************************************************************************** +\ for return data a buffer of at least 252 bytes must be present! +\ see spec: SPC-3 (r23) / clauses 4.5 and 6.27 +\ *************************************************************************** +\ command code: +03 CONSTANT scsi-cmd-request-sense +\ CDB structure: +STRUCT + /c FIELD request-sense>operation-code \ 03h + 3 FIELD request-sense>reserved \ unused + /c FIELD request-sense>allocation-length \ buffer-length for data response + /c FIELD request-sense>control \ control byte as specified in SAM-4 +CONSTANT scsi-length-request-sense + +\ cdb build: +: scsi-build-request-sense ( alloc-len cdb -- ) + >r ( alloc-len ) ( R: -- cdb ) + r@ scsi-length-request-sense erase ( alloc-len ) + scsi-cmd-request-sense r@ ( alloc-len cmd cdb ) + request-sense>operation-code c! ( alloc-len ) + dup d# 252 > \ buffer length too big ? + IF + scsi-inc-errors + drop d# 252 \ replace with 252 + ELSE + dup d# 18 < \ allocated buffer too small ? + IF + scsi-inc-errors + drop 0 \ reject return data + THEN + THEN ( alloclen ) + r@ request-sense>allocation-length c! ( ) + scsi-param-control r> request-sense>control c! ( alloc-len cdb ) ( R: cdb -- ) + scsi-length-request-sense to scsi-param-size \ update CDB length +; + +\ ---------------------------------------- +\ SCSI-Response: SENSE_DATA +\ ---------------------------------------- +70 CONSTANT scsi-response(request-sense-0) +71 CONSTANT scsi-response(request-sense-1) + +STRUCT + /c FIELD sense-data>response-code \ 70h (current errors) or 71h (deferred errors) + /c FIELD sense-data>obsolete + /c FIELD sense-data>sense-key \ D3..D0 = sense key, D7 = EndOfMedium + /l FIELD sense-data>info + /c FIELD sense-data>alloc-length \ <= 244 (for max size) + /l FIELD sense-data>command-info + /c FIELD sense-data>asc \ additional sense key + /c FIELD sense-data>ascq \ additional sense key qualifier + /c FIELD sense-data>unit-code + 3 FIELD sense-data>key-specific + /c FIELD sense-data>add-sense-bytes \ start of appended extra bytes +CONSTANT scsi-length-sense-data + +\ ---------------------------------------- +\ get from SCSI response block: +\ - Additional Sense Code Qualifier +\ - Additional Sense Code +\ - sense-key +\ ---------------------------------------- +\ Forth Word: scsi-get-sense-data ( addr -- ascq asc sense-key ) +\ ---------------------------------------- +: scsi-get-sense-data ( addr -- ascq asc sense-key ) + >r ( R: -- addr ) + r@ sense-data>response-code c@ 7f and 72 >= IF + r@ 3 + c@ ( ascq ) + r@ 2 + c@ ( ascq asc ) + r> 1 + c@ 0f and ( ascq asc sense-key ) + ELSE + r@ sense-data>ASCQ c@ ( ascq ) + r@ sense-data>ASC c@ ( ascq asc ) + r> sense-data>sense-key c@ 0f and ( ascq asc sense-key ) ( R: addr -- ) + THEN +; + +\ -------------------------------------------------------------------------- +\ Forth Word: scsi-get-sense-data? ( addr -- false | ascq asc sense-key true ) +\ -------------------------------------------------------------------------- +: scsi-get-sense-data? ( addr -- false | ascq asc sense-key true ) + dup + sense-data>response-code c@ + 7e AND dup 70 = swap 72 = or \ Response code (some devices have MSB set) + IF + scsi-get-sense-data TRUE + ELSE + drop FALSE \ drop addr + THEN + +; + +\ -------------------------------------------------------------------------- +\ Forth Word: scsi-get-sense-ID? ( addr -- false | sense-ID true ) +\ same as scsi-get-sense-data? but returns +\ a single word composed of: sense-key<<16 | asc<<8 | ascq +\ -------------------------------------------------------------------------- +: scsi-get-sense-ID? ( addr -- false | ascq asc sense-key true ) + dup + sense-data>response-code c@ + 7e AND 70 = \ Response code (some devices have MSB set) + IF + scsi-get-sense-data ( ascq asc sense-key ) + 10 lshift ( ascq asc sense-key16 ) + swap 8 lshift or ( ascq sense-key+asc ) + swap or \ 24-bit sense-ID ( sense-key+asc+ascq ) + TRUE + ELSE + drop FALSE \ drop addr + THEN +; + +\ *************************************************************************** +\ SCSI-Command: INQUIRY +\ Type: Primary Command (SPC-3 clause 6.4) +\ *************************************************************************** +\ Forth Word: scsi-build-inquiry ( alloc-len cdb -- ) +\ *************************************************************************** +\ command code: +12 CONSTANT scsi-cmd-inquiry + +\ CDB structure +STRUCT + /c FIELD inquiry>operation-code \ 0x12 + /c FIELD inquiry>reserved \ + EVPD-Bit (vital product data) + /c FIELD inquiry>page-code \ page code for vital product data (if used) + /w FIELD inquiry>allocation-length \ length of Data-In-Buffer + /c FIELD inquiry>control \ control byte as specified in SAM-4 +CONSTANT scsi-length-inquiry + +\ Setup command INQUIRY +: scsi-build-inquiry ( alloc-len cdb -- ) + dup scsi-length-inquiry erase \ 6 bytes CDB + scsi-cmd-inquiry over ( alloc-len cdb cmd cdb ) + inquiry>operation-code c! ( alloc-len cdb ) + scsi-param-control over inquiry>control c! ( alloc-len cdb ) + inquiry>allocation-length w! \ size of Data-In Buffer + scsi-length-inquiry to scsi-param-size \ update CDB length +; + +\ ---------------------------------------- +\ block structure of inquiry return data: +\ ---------------------------------------- +STRUCT + /c FIELD inquiry-data>peripheral \ qualifier and device type + /c FIELD inquiry-data>reserved1 + /c FIELD inquiry-data>version \ supported SCSI version (1,2,3) + /c FIELD inquiry-data>data-format + /c FIELD inquiry-data>add-length \ total block length - 4 + /c FIELD inquiry-data>flags1 + /c FIELD inquiry-data>flags2 + /c FIELD inquiry-data>flags3 + d# 8 FIELD inquiry-data>vendor-ident \ vendor string + d# 16 FIELD inquiry-data>product-ident \ device string + /l FIELD inquiry-data>product-revision \ revision string + d# 20 FIELD inquiry-data>vendor-specific \ optional params +\ can be increased by vendor specific fields +CONSTANT scsi-length-inquiry-data + +\ *************************************************************************** +\ SCSI-Command: READ CAPACITY (10) +\ Type: Block Command (SBC-3 clause 5.12) +\ *************************************************************************** +\ Forth Word: scsi-build-read-capacity-10 ( cdb -- ) +\ *************************************************************************** +25 CONSTANT scsi-cmd-read-capacity-10 \ command code + +STRUCT \ SCSI 10-byte CDB structure + /c FIELD read-cap-10>operation-code + /c FIELD read-cap-10>reserved1 + /l FIELD read-cap-10>lba + /w FIELD read-cap-10>reserved2 + /c FIELD read-cap-10>reserved3 + /c FIELD read-cap-10>control +CONSTANT scsi-length-read-cap-10 + +\ Setup READ CAPACITY (10) command +: scsi-build-read-cap-10 ( cdb -- ) + dup scsi-length-read-cap-10 erase ( cdb ) + scsi-cmd-read-capacity-10 over ( cdb cmd cdb ) + read-cap-10>operation-code c! ( cdb ) + scsi-param-control swap read-cap-10>control c! ( ) + scsi-length-read-cap-10 to scsi-param-size \ update CDB length +; + +\ ---------------------------------------- +\ get from SCSI response block: +\ - Additional Sense Code Qualifier +\ - Additional Sense Code +\ - sense-key +\ ---------------------------------------- +\ Forth Word: scsi-get-capacity-10 ( addr -- block-size #blocks ) +\ ---------------------------------------- +\ Block structure +STRUCT + /l FIELD read-cap-10-data>max-lba + /l FIELD read-cap-10-data>block-size +CONSTANT scsi-length-read-cap-10-data + +\ get data-block +: scsi-get-capacity-10 ( addr -- block-size #blocks ) + >r ( addr -- ) ( R: -- addr ) + r@ read-cap-10-data>block-size l@ ( block-size ) + r> read-cap-10-data>max-lba l@ ( block-size #blocks ) ( R: addr -- ) +; + +\ *************************************************************************** +\ SCSI-Command: READ CAPACITY (16) +\ Type: Block Command (SBC-3 clause 5.13) +\ *************************************************************************** +\ Forth Word: scsi-build-read-capacity-16 ( cdb -- ) +\ *************************************************************************** +9e CONSTANT scsi-cmd-read-capacity-16 \ command code + +STRUCT \ SCSI 16-byte CDB structure + /c FIELD read-cap-16>operation-code + /c FIELD read-cap-16>service-action + /l FIELD read-cap-16>lba-high + /l FIELD read-cap-16>lba-low + /l FIELD read-cap-16>allocation-length \ should be 32 + /c FIELD read-cap-16>reserved + /c FIELD read-cap-16>control +CONSTANT scsi-length-read-cap-16 + +\ Setup READ CAPACITY (16) command +: scsi-build-read-cap-16 ( cdb -- ) + >r r@ ( R: -- cdb ) + scsi-length-read-cap-16 erase ( ) + scsi-cmd-read-capacity-16 ( code ) + r@ read-cap-16>operation-code c! ( ) + 10 r@ read-cap-16>service-action c! + d# 32 \ response size 32 bytes + r@ read-cap-16>allocation-length l! ( ) + scsi-param-control r> read-cap-16>control c! ( R: cdb -- ) + scsi-length-read-cap-16 to scsi-param-size \ update CDB length +; + +\ ---------------------------------------- +\ get from SCSI response block: +\ - Block Size (in Bytes) +\ - Number of Blocks +\ ---------------------------------------- +\ Forth Word: scsi-get-capacity-16 ( addr -- block-size #blocks ) +\ ---------------------------------------- +\ Block structure for return data +STRUCT + /l FIELD read-cap-16-data>max-lba-high \ upper quadlet of Max-LBA + /l FIELD read-cap-16-data>max-lba-low \ lower quadlet of Max-LBA + /l FIELD read-cap-16-data>block-size \ logical block length in bytes + /c FIELD read-cap-16-data>protect \ type of protection (4 bits) + /c FIELD read-cap-16-data>exponent \ logical blocks per physical blocks + /w FIELD read-cap-16-data>lowest-aligned \ first LBA of a phsy. block + 10 FIELD read-cap-16-data>reserved \ 16 reserved bytes +CONSTANT scsi-length-read-cap-16-data \ results in 32 + +\ get data-block +: scsi-get-capacity-16 ( addr -- block-size #blocks ) + >r ( R: -- addr ) + r@ read-cap-16-data>block-size l@ ( block-size ) + r@ read-cap-16-data>max-lba-high l@ ( block-size #blocks-high ) + d# 32 lshift ( block-size #blocks-upper ) + r> read-cap-16-data>max-lba-low l@ + ( block-size #blocks ) ( R: addr -- ) +; + +\ *************************************************************************** +\ SCSI-Command: MODE SENSE (10) +\ Type: Primary Command (SPC-3 clause 6.10) +\ *************************************************************************** +\ Forth Word: scsi-build-mode-sense-10 ( alloc-len subpage page cdb -- ) +\ *************************************************************************** +5a CONSTANT scsi-cmd-mode-sense-10 + +\ CDB structure +STRUCT + /c FIELD mode-sense-10>operation-code + /c FIELD mode-sense-10>res-llbaa-dbd-res + /c FIELD mode-sense-10>pc-page-code \ page code + page control + /c FIELD mode-sense-10>sub-page-code + 3 FIELD mode-sense-10>reserved2 + /w FIELD mode-sense-10>allocation-length + /c FIELD mode-sense-10>control +CONSTANT scsi-length-mode-sense-10 + +: scsi-build-mode-sense-10 ( alloc-len subpage page cdb -- ) + >r ( alloc-len subpage page ) ( R: -- cdb ) + r@ scsi-length-mode-sense-10 erase \ 10 bytes CDB + scsi-cmd-mode-sense-10 ( alloc-len subpage page cmd ) + r@ mode-sense-10>operation-code c! ( alloc-len subpage page ) + 10 r@ mode-sense-10>res-llbaa-dbd-res c! \ long LBAs accepted + r@ mode-sense-10>pc-page-code c! ( alloc-len subpage ) + r@ mode-sense-10>sub-page-code c! ( alloc-len ) + r@ mode-sense-10>allocation-length w! ( ) + + scsi-param-control r> mode-sense-10>control c! ( R: cdb -- ) + scsi-length-mode-sense-10 to scsi-param-size \ update CDB length +; + +\ return data processing +\ (see spec: SPC-3 clause 7.4.3) + +STRUCT + /w FIELD mode-sense-10-data>head-length + /c FIELD mode-sense-10-data>head-medium + /c FIELD mode-sense-10-data>head-param + /c FIELD mode-sense-10-data>head-longlba + /c FIELD mode-sense-10-data>head-reserved + /w FIELD mode-sense-10-data>head-descr-len +CONSTANT scsi-length-mode-sense-10-data + +\ **************************************** +\ This function shows the mode page header +\ helpful for further analysis +\ **************************************** +: .mode-sense-data ( addr -- ) + cr + dup mode-sense-10-data>head-length + w@ ." Mode Length: " .d space + dup mode-sense-10-data>head-medium + c@ ." / Medium Type: " .d space + dup mode-sense-10-data>head-longlba + c@ ." / Long LBA: " .d space + mode-sense-10-data>head-descr-len + w@ ." / Descr. Length: " .d +; + +\ *************************************************************************** +\ SCSI-Command: READ (6) +\ Type: Block Command (SBC-3 clause 5.7) +\ *************************************************************************** +\ Forth Word: scsi-build-read-6 ( block# #blocks cdb -- ) +\ *************************************************************************** +\ this SCSI command uses 21 bits to represent start LBA +\ and 8 bits to specify the numbers of blocks to read +\ The value of 0 blocks is interpreted as 256 blocks +\ +\ command code +08 CONSTANT scsi-cmd-read-6 + +\ CDB structure +STRUCT + /c FIELD read-6>operation-code \ 08h + /c FIELD read-6>block-address-msb \ upper 5 bits + /w FIELD read-6>block-address \ lower 16 bits + /c FIELD read-6>length \ number of blocks to read + /c FIELD read-6>control \ CDB control +CONSTANT scsi-length-read-6 + +: scsi-build-read-6 ( block# #blocks cdb -- ) + >r ( block# #blocks ) ( R: -- cdb ) + r@ scsi-length-read-6 erase \ 6 bytes CDB + scsi-cmd-read-6 r@ read-6>operation-code c! ( block# #blocks ) + + \ check block count to read (#blocks) + dup d# 255 > \ #blocks exceeded limit ? + IF + scsi-inc-errors + drop 1 \ replace with any valid number + THEN + r@ read-6>length c! \ set #blocks to read + + \ check starting block number (block#) + dup 1fffff > \ check address upper limit + IF + scsi-inc-errors + drop \ remove original block# + 1fffff \ replace with any valid address + THEN + dup d# 16 rshift + r@ read-6>block-address-msb c! \ set upper 5 bits + ffff and + r@ read-6>block-address w! \ set lower 16 bits + scsi-param-control r> read-6>control c! ( R: cdb -- ) + scsi-length-read-6 to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: READ (10) +\ Type: Block Command (SBC-3 clause 5.8) +\ *************************************************************************** +\ Forth Word: scsi-build-read-10 ( block# #blocks cdb -- ) +\ *************************************************************************** +\ command code +28 CONSTANT scsi-cmd-read-10 + +\ CDB structure +STRUCT + /c FIELD read-10>operation-code + /c FIELD read-10>protect + /l FIELD read-10>block-address \ logical block address (32bits) + /c FIELD read-10>group + /w FIELD read-10>length \ transfer length (16-bits) + /c FIELD read-10>control +CONSTANT scsi-length-read-10 + +: scsi-build-read-10 ( block# #blocks cdb -- ) + >r ( block# #blocks ) ( R: -- cdb ) + r@ scsi-length-read-10 erase \ 10 bytes CDB + scsi-cmd-read-10 r@ read-10>operation-code c! ( block# #blocks ) + r@ read-10>length w! ( block# ) + r@ read-10>block-address l! ( ) + scsi-param-control r> read-10>control c! ( R: cdb -- ) + scsi-length-read-10 to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: READ (12) +\ Type: Block Command (SBC-3 clause 5.9) +\ *************************************************************************** +\ Forth Word: scsi-build-read-12 ( block# #blocks cdb -- ) +\ *************************************************************************** +\ command code +a8 CONSTANT scsi-cmd-read-12 + +\ CDB structure +STRUCT + /c FIELD read-12>operation-code \ code: a8 + /c FIELD read-12>protect \ RDPROTECT, DPO, FUA, FUA_NV + /l FIELD read-12>block-address \ lba + /l FIELD read-12>length \ transfer length (32bits) + /c FIELD read-12>group \ group number + /c FIELD read-12>control +CONSTANT scsi-length-read-12 + +: scsi-build-read-12 ( block# #blocks cdb -- ) + >r ( block# #blocks ) ( R: -- cdb ) + r@ scsi-length-read-12 erase \ 12 bytes CDB + scsi-cmd-read-12 r@ read-12>operation-code c! ( block# #blocks ) + r@ read-12>length l! ( block# ) + r@ read-12>block-address l! ( ) + scsi-param-control r> read-12>control c! ( R: cdb -- ) + scsi-length-read-12 to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: READ with autodetection of required command +\ read(10) or read(12) depending on parameter size +\ (read(6) removed because obsolete in some cases (USB)) +\ Type: Block Command +\ *************************************************************************** +\ Forth Word: scsi-build-read? ( block# #blocks cdb -- ) +\ +\ +----------------+---------------------------| +\ | block# (lba) | #block (transfer-length) | +\ +-----------+----------------+---------------------------| +\ | read-6 | 16-Bits | 8 Bits | +\ | read-10 | 32-Bits | 16 Bits | +\ | read-12 | 32-Bits | 32 Bits | +\ *************************************************************************** +: scsi-build-read? ( block# #blocks cdb -- length ) + over ( block# #blocks cdb #blocks ) + fffe > \ tx-length (#blocks) exceeds 16-bit limit ? + IF + scsi-build-read-12 ( block# #blocks cdb -- ) + scsi-length-read-12 ( length ) + ELSE ( block# #blocks cdb ) + scsi-build-read-10 ( block# #blocks cdb -- ) + scsi-length-read-10 ( length ) + THEN +; + +\ *************************************************************************** +\ SCSI-Command: START STOP UNIT +\ Type: Block Command (SBC-3 clause 5.19) +\ *************************************************************************** +\ Forth Word: scsi-build-start-stop-unit ( state# cdb -- ) +\ *************************************************************************** +\ command code +1b CONSTANT scsi-cmd-start-stop-unit + +\ CDB structure +STRUCT + /c FIELD start-stop-unit>operation-code + /c FIELD start-stop-unit>immed + /w FIELD start-stop-unit>reserved + /c FIELD start-stop-unit>pow-condition + /c FIELD start-stop-unit>control +CONSTANT scsi-length-start-stop-unit + +\ START/STOP constants +\ (see spec: SBC-3 clause 5.19) +f1 CONSTANT scsi-const-active-power \ param used for start-stop-unit +f2 CONSTANT scsi-const-idle-power \ param used for start-stop-unit +f3 CONSTANT scsi-const-standby-power \ param used for start-stop-unit +3 CONSTANT scsi-const-load \ param used for start-stop-unit +2 CONSTANT scsi-const-eject \ param used for start-stop-unit +1 CONSTANT scsi-const-start +0 CONSTANT scsi-const-stop + +: scsi-build-start-stop-unit ( state# cdb -- ) + >r ( state# ) ( R: -- cdb ) + r@ scsi-length-start-stop-unit erase \ 6 bytes CDB + scsi-cmd-start-stop-unit r@ start-stop-unit>operation-code c! + dup 3 > + IF + 4 lshift \ shift to upper nibble + THEN ( state ) + r@ start-stop-unit>pow-condition c! ( ) + scsi-param-control r> start-stop-unit>control c! ( R: cdb -- ) + scsi-length-start-stop-unit to scsi-param-size \ update CDB length +; + +\ *************************************************************************** +\ SCSI-Command: SEEK(10) +\ Type: Block Command (obsolete) +\ *************************************************************************** +\ Forth Word: scsi-build-seek ( state# cdb -- ) +\ Obsolete function (last listed in spec SBC / Nov. 1997) +\ implemented only for the sake of completeness +\ *************************************************************************** +\ command code +2b CONSTANT scsi-cmd-seek + +\ CDB structure +STRUCT + /c FIELD seek>operation-code + /c FIELD seek>reserved1 + /l FIELD seek>lba + 3 FIELD seek>reserved2 + /c FIELD seek>control +CONSTANT scsi-length-seek + +: scsi-build-seek ( lba cdb -- ) + >r ( lba ) ( R: -- cdb ) + r@ scsi-length-seek erase \ 10 bytes CDB + scsi-cmd-seek r@ seek>operation-code c! + r> seek>lba l! ( ) ( R: cdb -- ) + scsi-length-seek to scsi-param-size \ update CDB length +; + +\ **************************************************************************** +\ CDROM media event stuff +\ **************************************************************************** + +STRUCT + /w FIELD media-event-data-len + /c FIELD media-event-nea-class + /c FIELD media-event-supp-class + /l FIELD media-event-data +CONSTANT scsi-length-media-event + +: scsi-build-get-media-event ( cdb -- ) + dup c erase ( cdb ) + 4a over c! ( cdb ) + 01 over 1 + c! + 10 over 4 + c! + 08 over 8 + c! + drop +; + + + +\ *************************************************************************** +\ SCSI-Utility: .sense-code +\ *************************************************************************** +\ this utility prints a string associated to the sense code +\ see specs: SPC-3/r23 clause 4.5.6 +\ *************************************************************************** +: .sense-text ( scode -- ) + case + 0 OF s" OK" ENDOF + 1 OF s" RECOVERED ERR" ENDOF + 2 OF s" NOT READY" ENDOF + 3 OF s" MEDIUM ERROR" ENDOF + 4 OF s" HARDWARE ERR" ENDOF + 5 OF s" ILLEGAL REQUEST" ENDOF + 6 OF s" UNIT ATTENTION" ENDOF + 7 OF s" DATA PROTECT" ENDOF + 8 OF s" BLANK CHECK" ENDOF + 9 OF s" VENDOR SPECIFIC" ENDOF + a OF s" COPY ABORTED" ENDOF + b OF s" ABORTED COMMAND" ENDOF + d OF s" VOLUME OVERFLOW" ENDOF + e OF s" MISCOMPARE" ENDOF + dup OF s" UNKNOWN" ENDOF + endcase + 5b emit type 5d emit +; + +\ *************************************************************************** +\ SCSI-Utility: .status-code +\ *************************************************************************** +\ this utility prints a string associated to the status code +\ see specs: SAM-3/r14 clause 5.3 +\ *************************************************************************** +: .status-text ( stat -- ) + case + 00 OF s" GOOD" ENDOF + 02 OF s" CHECK CONDITION" ENDOF + 04 OF s" CONDITION MET" ENDOF + 08 OF s" BUSY" ENDOF + 18 OF s" RESERVATION CONFLICT" ENDOF + 28 OF s" TASK SET FULL" ENDOF + 30 OF s" ACA ACTIVE" ENDOF + 40 OF s" TASK ABORTED" ENDOF + dup OF s" UNKNOWN" ENDOF + endcase + 5b emit type 5d emit +; + +\ *************************************************************************** +\ SCSI-Utility: .capacity-text +\ *************************************************************************** +\ utility that shows total capacity on screen by use of the return data +\ from read-capacity calculation is SI conform (base 10) +\ *************************************************************************** +\ sub function to print a 3 digit decimal +\ number with 2 post decimal positions xxx.yy +: .dec3-2 ( prenum postnum -- ) + swap + base @ >r \ save actual base setting + decimal \ show decimal values + 4 .r 2e emit + dup 9 <= IF 30 emit THEN .d \ 3 pre-decimal, right aligned + r> base ! \ restore base +; + +: .capacity-text ( block-size #blocks -- ) + scsi-param-debug \ debugging flag set ? + IF \ show additional info + 2dup + cr + ." LBAs: " .d \ highest logical block number + ." / Block-Size: " .d + ." / Total Capacity: " + THEN + * \ calculate total capacity + dup d# 1000000000000 >= \ check terabyte limit + IF + d# 1000000000000 /mod + swap + d# 10000000000 / \ limit remainder to two digits + .dec3-2 ." TB" \ show terabytes as xxx.yy + ELSE + dup d# 1000000000 >= \ check gigabyte limit + IF + d# 1000000000 /mod + swap + d# 10000000 / + .dec3-2 ." GB" \ show gigabytes as xxx.yy + ELSE + dup d# 1000000 >= + IF + d# 1000000 /mod \ check mega byte limit + swap + d# 10000 / + .dec3-2 ." MB" \ show megabytes as xxx.yy + ELSE + dup d# 1000 >= \ check kilo byte limit + IF + d# 1000 /mod + swap + d# 10 / + .dec3-2 ." kB" + ELSE + .d ." Bytes" + THEN + THEN + THEN + THEN +; + +\ *************************************************************************** +\ SCSI-Utility: .inquiry-text ( addr -- ) +\ *************************************************************************** +\ utility that shows: +\ vendor-ident product-ident and revision +\ from an inquiry return data block (addr) +\ *************************************************************************** +: .inquiry-text ( addr -- ) + 22 emit \ enclose text with " + dup inquiry-data>vendor-ident 8 type space + dup inquiry-data>product-ident 10 type space + inquiry-data>product-revision 4 type + 22 emit +; + +\ *************************************************************************** +\ SCSI-Utility: scsi-supp-init ( -- ) +\ *************************************************************************** +\ utility that helps to ensure that parameters are set to valid values +: scsi-supp-init ( -- ) + false to scsi-param-debug \ no debug strings + h# 0 to scsi-param-size + h# 0 to scsi-param-control \ common CDB control byte + d# 0 to scsi-param-errors \ local errors (param limits) +; + +\ *************************************************************************** +\ Constants used by SCSI controller's execute-scsi-command +\ *************************************************************************** +true CONSTANT scsi-dir-read +false CONSTANT scsi-dir-write + + +\ *************************************************************************** +\ scsi loader +\ *************************************************************************** +0 VALUE scsi-context \ addr of word list on top + + +\ **************************************************************************** +\ open scsi-support by adding a new word list on top of search path +\ precondition: scsi-support.fs must have been included +\ **************************************************************************** +: scsi-init ( -- ) + also scsi-words \ append scsi word-list + context to scsi-context \ save for close process + scsi-supp-init \ preset all scsi-param-xxx values + scsi-param-debug + IF + space ." SCSI-SUPPORT OPENED" cr + .wordlists + THEN +; + +\ **************************************************************************** +\ close scsi-session and remove scsi word list (if exists) +\ **************************************************************************** +\ if 'previous' is used without a preceding 'also' all forth words are lost ! +\ **************************************************************************** +: scsi-close ( -- ) +\ FIXME This only works if scsi-words is the last vocabulary on the stack +\ Instead we could use get-order to find us on the "wordlist stack", +\ remove us and write the wordlist stack back with set-order. +\ BUT: Is this worth the effort? + + scsi-param-debug + IF + space ." Closing SCSI-SUPPORT .. " cr + THEN + context scsi-context = \ scsi word list still active ? + IF + scsi-param-errors 0<> \ any errors occurred ? + IF + cr ." ** WARNING: " scsi-param-errors .d + ." SCSI Errors occurred ** " cr + THEN + previous \ remove scsi word list on top + 0 to scsi-context \ prevent from being misinterpreted + ELSE + cr ." ** WARNING: Trying to close non-open SCSI-SUPPORT (1) ** " cr + THEN + scsi-param-debug + IF + .wordlists + THEN +; + + +s" scsi-init" $find drop \ return execution pointer, when included + +previous \ remove scsi word list from search path +definitions \ place next definitions into previous list + diff --git a/src/roms/SLOF/slof/fs/search.fs b/src/roms/SLOF/slof/fs/search.fs new file mode 100644 index 0000000..3acca2f --- /dev/null +++ b/src/roms/SLOF/slof/fs/search.fs @@ -0,0 +1,89 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ +\ Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +\ + + +\ stuff we should already have: + +: linked ( var -- ) here over @ , swap ! ; + +HEX + +\ \ \ +\ \ \ Wordlists +\ \ \ + +VARIABLE wordlists forth-wordlist wordlists ! + +\ create a new wordlist +: wordlist ( -- wid ) here wordlists linked 0 , ; + + +\ \ \ +\ \ \ Search order +\ \ \ + +10 CONSTANT max-in-search-order \ should define elsewhere +\ CREATE search-order max-in-search-order cells allot \ stack of wids \ is in engine now +\ search-order VALUE context \ top of stack \ is in engine now + +: also ( -- ) clean-hash context dup cell+ dup to context >r @ r> ! ; +: previous ( -- ) clean-hash context cell- to context ; +: only ( -- ) clean-hash search-order to context ( minimal-wordlist search-order ! ) ; +: seal ( -- ) clean-hash context @ search-order dup to context ! ; + +: get-order ( -- wid_n .. wid_1 n ) + context >r search-order BEGIN dup r@ u<= WHILE + dup @ swap cell+ REPEAT r> drop + search-order - cell / ; +: set-order ( wid_n .. wid_1 n -- ) \ XXX: special cases for 0, -1 + clean-hash 1- cells search-order + dup to context + BEGIN dup search-order u>= WHILE + dup >r ! r> cell- REPEAT drop ; + + +\ \ \ +\ \ \ Compilation wordlist +\ \ \ + +: get-current ( -- wid ) current ; +: set-current ( wid -- ) to current ; + +: definitions ( -- ) context @ set-current ; + + +\ \ \ +\ \ \ Vocabularies +\ \ \ + +: VOCABULARY ( C: "name" -- ) ( -- ) CREATE wordlist drop DOES> clean-hash context ! ; +\ : VOCABULARY ( C: "name" -- ) ( -- ) wordlist CREATE , DOES> @ context ! ; +\ XXX we'd like to swap forth and forth-wordlist around (for .voc 's sake) +: FORTH ( -- ) clean-hash forth-wordlist context ! ; + +: .voc ( wid -- ) \ display name for wid \ needs work ( body> or something like that ) + dup cell- @ ['] vocabulary ['] forth within IF + 2 cells - >name name>string type ELSE u. THEN space ; +: vocs ( -- ) \ display all wordlist names + cr wordlists BEGIN @ dup WHILE dup .voc REPEAT drop ; +: order ( -- ) + cr ." context: " get-order 0 ?DO .voc LOOP + cr ." current: " get-current .voc ; + + + + +\ some handy helper +: voc-find ( wid -- 0 | link ) + clean-hash cell+ @ (find) clean-hash ; diff --git a/src/roms/SLOF/slof/fs/slof-logo.fs b/src/roms/SLOF/slof/fs/slof-logo.fs new file mode 100644 index 0000000..53d3184 --- /dev/null +++ b/src/roms/SLOF/slof/fs/slof-logo.fs @@ -0,0 +1,20 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: .slof-logo + cr ." ..`. .. ....... .. ...... ......." + cr ." ..`...`''.`'. .''``````..''. .`''```''`. `''``````" + cr ." .`` .:' ': `''..... .''. ''` .''..''......." + cr ." ``.':.';. ``````''`.''. .''. ''``''`````'`" + cr ." ``.':':` .....`''.`'`...... `'`.....`''.`'` " + cr ." .`.`'`` .'`'`````. ``'''''' ``''`'''`. `'` " +; diff --git a/src/roms/SLOF/slof/fs/sms/sms-load.fs b/src/roms/SLOF/slof/fs/sms/sms-load.fs new file mode 100644 index 0000000..8e4db80 --- /dev/null +++ b/src/roms/SLOF/slof/fs/sms/sms-load.fs @@ -0,0 +1,70 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +false VALUE (sms-loaded?) + +false value (sms-available?) + +s" sms.fs" romfs-lookup IF true to (sms-available?) drop THEN + +(sms-available?) [IF] + +#include "packages/sms.fs" + +\ Initialize SMS NVRAM handling. +#include "sms-nvram.fs" + +\ Dynamically load sms code from the romfs file +\ Assumption is that skeleton sms package already exists +\ but aside of open & close, all other methods are in a romfs file (sms.fs) +\ Here we open the package and load the rest of the functionality + +\ After that, one needs to find-device and execute sms-start method +\ The shorthand for that is given as (global) sms-start word + +: $sms-node s" /packages/sms" ; + +: (sms-init-package) ( -- true|false ) + (sms-loaded?) ?dup IF EXIT THEN + $sms-node ['] find-device catch IF 2drop false EXIT THEN + s" sms.fs" [COMPILE] included + device-end + true dup to (sms-loaded?) +; + +\ External wrapper for sms package method +: (sms-evaluate) ( addr len -- ) + (sms-init-package) not IF + cr ." SMS is not available." cr 2drop exit + THEN + + s" Entering SMS ..." type + disable-watchdog + reset-dual-emit + + \ if we only had execute-device-method... + 2>r $sms-node find-device + 2r> evaluate + device-end + vpd-boot-import +; + +: sms-start ( -- ) s" sms-start" (sms-evaluate) ; +: sms-fru-replacement ( -- ) s" sms-fru-replacement" (sms-evaluate) ; + +[ELSE] + +: sms-start ( -- ) cr ." SMS is not available." cr ; +: sms-fru-replacement ( -- ) cr ." SMS FRU replacement is not available." cr ; + +[THEN] + diff --git a/src/roms/SLOF/slof/fs/sms/sms-nvram.fs b/src/roms/SLOF/slof/fs/sms/sms-nvram.fs new file mode 100644 index 0000000..4f5d6dd --- /dev/null +++ b/src/roms/SLOF/slof/fs/sms/sms-nvram.fs @@ -0,0 +1,124 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Initialize SMS NVRAM handling. + +: sms-init-nvram ( -- ) + nvram-partition-type-sms get-nvram-partition IF + cr ." Could not find SMS partition in NVRAM - " + nvram-partition-type-sms s" SMS" d# 1024 new-nvram-partition + ABORT" Failed to create SMS NVRAM partition" + 2dup erase-nvram-partition drop + + 2dup s" lang" s" 1" internal-set-env drop + + 2dup s" tftp-retries" s" 5" internal-set-env drop + 2dup s" tftp-blocksize" s" 512" internal-set-env drop + 2dup s" bootp-retries" s" 255" internal-set-env drop + 2dup s" client" s" 000.000.000.000" internal-set-env drop + 2dup s" server" s" 000.000.000.000" internal-set-env drop + 2dup s" gateway" s" 000.000.000.000" internal-set-env drop + 2dup s" netmask" s" 255.255.255.000" internal-set-env drop + 2dup s" net-protocol" s" 0" internal-set-env drop + 2dup s" net-flags" s" 0" internal-set-env drop + 2dup s" net-device" s" 0" internal-set-env drop + 2dup s" net-client-name" s" " internal-set-env drop + + 2dup s" scsi-spinup" s" 6" internal-set-env drop + 2dup s" scsi-id-0" s" 7" internal-set-env drop + 2dup s" scsi-id-1" s" 7" internal-set-env drop + 2dup s" scsi-id-2" s" 7" internal-set-env drop + 2dup s" scsi-id-3" s" 7" internal-set-env drop + ." created" cr + THEN + s" sms-nvram-partition" $2constant +; + +sms-init-nvram + +: sms-add-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-add-env drop ; +: sms-set-env ( "name" "value" -- ) sms-nvram-partition 2rot 2rot internal-set-env drop ; +: sms-get-env ( "name" -- "value" TRUE | FALSE) sms-nvram-partition 2swap internal-get-env ; + +: sms-get-net-device ( -- n ) s" net-device" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ; +: sms-set-net-device ( n -- ) (.d) s" net-device" 2swap sms-set-env ; + +: sms-get-net-flags ( -- n ) s" net-flags" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ; +: sms-set-net-flags ( n -- ) (.d) s" net-flags" 2swap sms-set-env ; + +: sms-get-net-protocol ( -- n ) s" net-protocol" sms-get-env IF $dnumber IF 0 THEN ELSE 0 THEN ; +: sms-set-net-protocol ( n -- ) (.d) s" net-protocol" 2swap sms-set-env ; + +: sms-get-lang ( -- n ) s" lang" sms-get-env IF $dnumber IF 1 THEN ELSE 1 THEN ; +: sms-set-lang ( n -- ) (.d) s" lang" 2swap sms-set-env ; + +: sms-get-bootp-retries ( -- n ) s" bootp-retries" sms-get-env IF $dnumber IF 255 THEN ELSE 255 THEN ; +: sms-set-bootp-retries ( n -- ) (.d) s" bootp-retries" 2swap sms-set-env ; + +: sms-get-tftp-retries ( -- n ) s" tftp-retries" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ; +: sms-set-tftp-retries ( n -- ) (.d) s" tftp-retries" 2swap sms-set-env ; + +: sms-get-tftp-blocksize ( -- n ) s" tftp-blocksize" sms-get-env IF $dnumber IF 5 THEN ELSE 5 THEN ; +: sms-set-tftp-blocksize ( n -- ) (.d) s" tftp-blocksize" 2swap sms-set-env ; + +: sms-get-client ( -- FALSE | n1 n2 n3 n4 TRUE ) s" client" sms-get-env IF (ipaddr) ELSE false THEN ; +: sms-set-client ( n1 n2 n3 n4 -- ) (ipformat) s" client" 2swap sms-set-env ; + +: sms-get-server ( -- FALSE | n1 n2 n3 n4 TRUE ) s" server" sms-get-env IF (ipaddr) ELSE false THEN ; +: sms-set-server ( n1 n2 n3 n4 -- ) (ipformat) s" server" 2swap sms-set-env ; + +: sms-get-gateway ( -- FALSE | n1 n2 n3 n4 TRUE ) s" gateway" sms-get-env IF (ipaddr) ELSE false THEN ; +: sms-set-gateway ( n1 n2 n3 n4 -- ) (ipformat) s" gateway" 2swap sms-set-env ; + +: sms-get-subnet ( -- FALSE | n1 n2 n3 n4 TRUE ) s" netmask" sms-get-env IF (ipaddr) ELSE false THEN ; +: sms-set-subnet ( n1 n2 n3 n4 -- ) (ipformat) s" netmask" 2swap sms-set-env ; + +: sms-get-client-name ( -- FALSE | addr len TRUE ) s" net-client-name" sms-get-env ; +: sms-set-client-name ( addr len -- ) s" net-client-name" 2swap sms-set-env ; + +: sms-get-scsi-spinup ( -- n ) s" scsi-spinup" sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ; +: sms-set-scsi-spinup ( n -- ) (.d) s" scsi-spinup" 2swap sms-set-env ; + +: sms-get-scsi-id ( n -- id ) s" scsi-id-" rot (.) $cat sms-get-env IF $dnumber IF 6 THEN ELSE 6 THEN ; +: sms-set-scsi-id ( id n -- ) swap (.d) rot s" scsi-id-" rot (.) $cat sms-set-env ; + + +\ generates the boot-file part of the boot string + +: sms-get-net-boot-file ( -- addr len ) + \ the format is + \ :[bootp,]siaddr,filename,ciaddr,giaddr,bootp-retries,tftp-retries + \ we choose dhcp as a default! + s" net" sms-get-net-device (.) $cat + s" :dhcp," $cat + sms-get-server IF (ipformat) $cat THEN + s" ," $cat + sms-get-client-name IF $cat THEN + s" ," $cat + sms-get-client IF (ipformat) $cat THEN + s" ," $cat + sms-get-gateway IF (ipformat) $cat THEN + s" ," $cat + \ If the number of retries is 255 (max), assume default timeout (10min) + sms-get-bootp-retries dup ff <> IF (.) $cat ELSE drop THEN + s" ," $cat + sms-get-tftp-retries (.) $cat + \ now write the string to the boot path + dup IF + \ This could be considered a memory leak, but it is only + \ executed once for booting so it is not a problem + strdup ( s" :" 2swap $cat strdup ) + THEN +; + +' sms-get-net-boot-file to furnish-boot-file + diff --git a/src/roms/SLOF/slof/fs/stack.fs b/src/roms/SLOF/slof/fs/stack.fs new file mode 100644 index 0000000..0f7e097 --- /dev/null +++ b/src/roms/SLOF/slof/fs/stack.fs @@ -0,0 +1,57 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Example: +\ +\ To get a 30 element stack, go: +\ +\ 0 > 30 new-stack my-stack +\ 0 > my-stack +\ 0 > 20 push 30 push +\ 0 > pop pop .s + +0 value current-stack + +: new-stack ( cells <>name -- ) + create >r here ( here R: cells ) + dup r@ 2 + cells ( here here bytes R: cells ) + dup allot erase ( here R: cells) + cell+ r> ( here+1cell cells ) + swap ! ( ) + DOES> to current-stack +; + +: reset-stack ( -- ) + 0 current-stack ! +; + +: stack-depth ( -- depth ) + current-stack @ +; + +: push ( value -- ) + current-stack @ + current-stack cell+ @ over <= ABORT" Stack overflow" + cells + 1 current-stack +! + current-stack 2 cells + + ! +; + +: pop ( -- value ) + current-stack @ 0= ABORT" Stack underflow" + current-stack @ cells + current-stack + cell+ @ + -1 current-stack +! +; + + diff --git a/src/roms/SLOF/slof/fs/start-up.fs b/src/roms/SLOF/slof/fs/start-up.fs new file mode 100644 index 0000000..f1488fa --- /dev/null +++ b/src/roms/SLOF/slof/fs/start-up.fs @@ -0,0 +1,171 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +: (boot) ( -- ) + s" Executing following boot-command: " + boot-command $cat nvramlog-write-string-cr + s" boot-command" evaluate \ get boot command + ['] evaluate catch ?dup IF \ and execute it + ." boot attempt returned: " + abort"-str @ count type cr + nip nip \ drop string from 1st evaluate + throw + THEN +; + +\ Note: The following ESC sequences has to be handled: +\ 1B 4F 50 +\ 1B 5B 31 31 7E + +\ Reads and converts the function key. +\ key = F1 -- n = 1 +: (function-key) ( -- n ) + key? IF + key CASE + 50 OF 1 ENDOF + 7e OF 1 ENDOF + dup OF 0 ENDOF + ENDCASE + THEN +; + +\ Checks if an ESC sequence occurs. +: (esc-sequence) ( -- n ) + key? IF + key CASE + 4f OF (function-key) ENDOF + 5b OF + key key (function-key) ENDOF + dup OF 0 ENDOF + ENDCASE + THEN +; + +: (s-pressed) ( -- ) + s" An 's' has been pressed. Entering Open Firmware Prompt" + nvramlog-write-string-cr +; + +: (boot?) ( -- ) + of-prompt? not auto-boot? and IF + (boot) + THEN +; + + +#include "sms/sms-load.fs" + + +\ Watchdog will be rearmed during load if use-load-watchdog variable is TRUE +TRUE VALUE use-load-watchdog? + +1 value my-boot-dev +1 value digit-val +0 value boot-dev-no + +: boot-selected + 1 to my-boot-dev + BEGIN parse-word dup WHILE + boot-dev-no my-boot-dev = IF + s" boot " 2swap $cat + ['] evaluate catch ?dup IF \ and execute it + ." boot attempt returned: " + abort"-str @ count type cr + throw + THEN + 0 0 load-list 2! + UNLOOP EXIT + ELSE + 2drop + THEN + my-boot-dev 1 + to my-boot-dev + REPEAT 2drop 0 0 load-list 2! + + (boot) +; + +: boot-start + \ Remove multiple F12 key presses if any + BEGIN key? WHILE + key drop + REPEAT + + decimal + BEGIN parse-word dup WHILE + my-boot-dev (u.) s" . " $cat type 2dup type ." : " de-alias type cr + my-boot-dev 1 + to my-boot-dev + REPEAT 2drop 0 0 load-list 2! + + cr BEGIN KEY dup emit + dup isdigit IF + dup 30 - to digit-val + boot-dev-no a * digit-val + to boot-dev-no + THEN + d = UNTIL + + boot-dev-no my-boot-dev < IF + s" boot-selected " s" $bootdev" evaluate $cat strdup evaluate + ELSE + ." Invalid choice!" cr + THEN + hex +; + +: boot-menu-start + ." Select boot device:" cr cr + s" boot-start " s" $bootdev" evaluate $cat strdup evaluate +; + +: boot-menu-enabled? ( -- true|false ) + s" qemu,boot-menu" get-chosen IF + decode-int 1 = IF + 2drop TRUE EXIT + THEN + 2drop + THEN + FALSE +; + +: f12-pressed? + 34 = >r 32 = r> and IF + TRUE + ELSE + FALSE + THEN +; + +: start-it ( -- ) + key? IF + key CASE + [char] s OF (s-pressed) ENDOF + 1b OF + (esc-sequence) CASE + 1 OF + console-clean-fifo + f12-pressed? boot-menu-enabled? and IF + boot-menu-start + ELSE + (boot?) + THEN + ENDOF + dup OF (boot?) ENDOF + ENDCASE + ENDOF + dup OF (boot?) ENDOF + ENDCASE + ELSE + (boot?) + THEN + + disable-watchdog FALSE to use-load-watchdog? + .banner +; diff --git a/src/roms/SLOF/slof/fs/term-io.fs b/src/roms/SLOF/slof/fs/term-io.fs new file mode 100644 index 0000000..52ce12a --- /dev/null +++ b/src/roms/SLOF/slof/fs/term-io.fs @@ -0,0 +1,97 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +: input ( dev-str dev-len -- ) + open-dev ?dup IF + \ Close old stdin: + s" stdin" get-chosen IF + decode-int nip nip ?dup IF close-dev THEN + THEN + \ Now set the new stdin: + encode-int s" stdin" set-chosen + THEN +; + +: output ( dev-str dev-len -- ) + open-dev ?dup IF + \ Close old stdout: + s" stdout" get-chosen IF + decode-int nip nip ?dup IF close-dev THEN + THEN + \ Now set the new stdout: + encode-int s" stdout" set-chosen + THEN +; + +: io ( dev-str dev-len -- ) + 2dup input output +; + + +1 BUFFER: (term-io-char-buf) + +: term-io-key ( -- char ) + s" stdin" get-chosen IF + decode-int nip nip dup 0= IF 0 EXIT THEN + >r BEGIN + (term-io-char-buf) 1 s" read" r@ $call-method + 0 > + UNTIL + (term-io-char-buf) c@ + r> drop + ELSE + [ ' key behavior compile, ] + THEN +; + +' term-io-key to key + +\ this word will check what the current chosen input device is: +\ - if it is a serial device, it will use serial-key? to check for available input +\ - if it is a keyboard, it will check if the "key-available?" method is implemented (i.e. for usb-keyboard) and use that +\ - if it's an hv console, use hvterm-key? +\ otherwise it will always return false +: term-io-key? ( -- true|false ) + s" stdin" get-chosen IF + decode-int nip nip dup 0= IF drop 0 EXIT THEN \ return false and exit if no stdin set + >r \ store ihandle on return stack + s" device_type" r@ ihandle>phandle ( propstr len phandle ) + get-property ( true | data dlen false ) + IF + \ device_type not found, return false and exit + false + ELSE + 1 - \ remove 1 from length to ignore null-termination char + \ device_type found, check wether it is serial or keyboard + 2dup s" serial" str= IF + 2drop serial-key? r> drop EXIT + THEN \ call serial-key, cleanup return-stack, exit + 2dup s" keyboard" str= IF + 2drop ( ) + \ keyboard found, check for key-available? method, execute it or return false + s" key-available?" r@ ihandle>phandle find-method IF + drop s" key-available?" r@ $call-method + ELSE + false + THEN + r> drop EXIT \ cleanup return-stack, exit + THEN + 2drop r> drop false EXIT \ unknown device_type cleanup return-stack, return false + THEN + ELSE + \ stdin not set, return false + false + THEN +; + +' term-io-key? to key? diff --git a/src/roms/SLOF/slof/fs/terminal.fs b/src/roms/SLOF/slof/fs/terminal.fs new file mode 100644 index 0000000..dc82e7b --- /dev/null +++ b/src/roms/SLOF/slof/fs/terminal.fs @@ -0,0 +1,213 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ \\\\\\\\\\\\\\ Global Data + +0 VALUE line# +0 VALUE column# +false VALUE inverse? +false VALUE inverse-screen? +18 VALUE #lines +50 VALUE #columns + +false VALUE cursor +false VALUE saved-cursor + + +\ \\\\\\\\\\\\\\ Structure/Implementation Dependent Methods + +defer draw-character \ 2B inited by display driver +defer reset-screen \ 2B inited by display driver +defer toggle-cursor \ 2B inited by display driver +defer erase-screen \ 2B inited by display driver +defer blink-screen \ 2B inited by display driver +defer invert-screen \ 2B inited by display driver +defer insert-characters \ 2B inited by display driver +defer delete-characters \ 2B inited by display driver +defer insert-lines \ 2B inited by display driver +defer delete-lines \ 2B inited by display driver +defer draw-logo \ 2B inited by display driver + +: nop-toggle-cursor ( nop ) ; +' nop-toggle-cursor to toggle-cursor + +\ \\\\\\\\\\\\\\ Implementation Independent Methods (Depend on Previous) +\ * +\ * +: (cursor-off) ( -- ) cursor dup to saved-cursor + IF toggle-cursor false to cursor THEN ; +: (cursor-on) ( -- ) cursor dup to saved-cursor + 0= IF toggle-cursor true to cursor THEN ; +: restore-cursor ( -- ) saved-cursor dup cursor + <> IF toggle-cursor to cursor ELSE drop THEN ; + +' (cursor-off) to cursor-off +' (cursor-on) to cursor-on + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ Generic device methods: +\ * + + +\ \\\\\\\\\\\\\\ Exported Interface: +\ * +\ * + +false VALUE esc-on +false VALUE csi-on +defer esc-process +0 VALUE esc-num-parm +0 VALUE esc-num-parm2 +0 VALUE saved-line# +0 VALUE saved-column# + +: get-esc-parm ( default -- value ) + esc-num-parm dup 0> IF nip ELSE drop THEN 0 to esc-num-parm ; +: get-esc-parm2 ( default -- value ) + esc-num-parm2 dup 0> IF nip ELSE drop THEN 0 to esc-num-parm2 ; +: set-esc-parm ( newdigit -- ) [char] 0 - esc-num-parm a * + to esc-num-parm ; + +: reverse-cursor ( oldpos -- newpos) dup IF 1 get-esc-parm - THEN ; +: advance-cursor ( bound oldpos -- newpos) tuck > IF 1 get-esc-parm + THEN ; +: erase-in-line #columns column# - dup 0> IF delete-characters ELSE drop THEN ; + +: terminal-line++ ( -- ) + line# 1+ dup #lines = IF 1- 0 to line# 1 delete-lines THEN + to line# +; + +0 VALUE dang +0 VALUE blipp +false VALUE stopcsi +0 VALUE term-background +7 VALUE term-foreground + +: set-term-color + dup d# 30 d# 39 between IF dup d# 30 - to term-foreground THEN + dup d# 40 d# 49 between IF dup d# 40 - to term-background THEN + 0 = IF + 0 to term-background + 7 to term-foreground + THEN + term-foreground term-background <= to inverse? +; + +: ansi-esc ( char -- ) + csi-on IF + dup [char] 0 [char] 9 between IF set-esc-parm + ELSE true to stopcsi CASE + [char] A OF line# reverse-cursor to line# ENDOF + [char] B OF #lines line# advance-cursor to line# ENDOF + [char] C OF #columns column# advance-cursor to column# ENDOF + [char] D OF column# reverse-cursor to column# ENDOF + [char] E OF ( FIXME: Cursor Next Line - No idea what does it mean ) + #lines line# advance-cursor to line# + ENDOF + [char] f OF + 1 get-esc-parm2 to line# column# get-esc-parm to column# + ENDOF + [char] H OF + 1 get-esc-parm2 to line# column# get-esc-parm to column# + ENDOF + ( second parameter delimiter for f and H commands ) + [char] ; OF false to stopcsi 0 get-esc-parm to esc-num-parm2 ENDOF + [char] ? OF false to stopcsi ENDOF ( FIXME: Ignore that for now ) + [char] l OF ENDOF ( FIXME: ?25l should hide cursor ) + [char] h OF ENDOF ( FIXME: ?25h should show cursor ) + [char] J OF + #lines line# - dup 0> IF + line# 1+ to line# delete-lines line# 1- to line# + ELSE drop THEN + erase-in-line + ENDOF + [char] K OF erase-in-line ENDOF + [char] L OF 1 get-esc-parm insert-lines ENDOF + [char] M OF 1 get-esc-parm delete-lines ENDOF + [char] @ OF 1 get-esc-parm insert-characters ENDOF + [char] P OF 1 get-esc-parm delete-characters ENDOF + [char] m OF 0 get-esc-parm set-term-color ENDOF + ( These are non-ANSI commands recommended by OpenBoot ) + [char] p OF inverse-screen? IF false to inverse-screen? + inverse? 0= to inverse? invert-screen + THEN + ENDOF + [char] q OF inverse-screen? 0= IF true to inverse-screen? + inverse? 0= to inverse? invert-screen + THEN + ENDOF +\ [char] s OF reset-screen ENDOF ( FIXME: this conflicts w. ANSI ) +\ [char] s OF line# to saved-line# column# to saved-column# ENDOF + [char] u OF saved-line# to line# saved-column# to column# ENDOF + dup dup to dang OF blink-screen ENDOF + ENDCASE stopcsi IF false to csi-on + false to esc-on 0 to esc-num-parm 0 to esc-num-parm2 THEN + THEN + ELSE CASE + ( DEV VT compatibility stuff used by accept.fs ) + [char] 7 OF line# to saved-line# column# to saved-column# ENDOF + [char] 8 OF saved-line# to line# saved-column# to column# ENDOF + [char] [ OF true to csi-on ENDOF + dup dup OF false to esc-on to blipp ENDOF + ENDCASE + csi-on 0= IF false to esc-on THEN 0 to esc-num-parm 0 to esc-num-parm2 + THEN +; + +' ansi-esc to esc-process +CREATE twtracebuf 4000 allot twtracebuf 4000 erase +twtracebuf VALUE twbp +0 VALUE twbc +0 VALUE twtrace-enabled? + +: twtrace + twbc 4000 = IF 0 to twbc twtracebuf to twbp THEN + dup twbp c! twbp 1+ to twbp twbc 1+ to twbc +; + +: terminal-write ( addr len -- actual-len ) + cursor-off + tuck bounds ?DO i c@ + twtrace-enabled? IF twtrace THEN + esc-on IF esc-process + ELSE CASE + 1B OF true to esc-on ENDOF + carret OF 0 to column# ENDOF + linefeed OF terminal-line++ ENDOF + bell OF blink-screen ENDOF + 9 ( TAB ) OF column# 7 + -8 and dup #columns < IF + to column# + ELSE drop THEN + ENDOF + B ( VT ) OF line# ?dup IF 1- to line# THEN ENDOF + C ( FF ) OF 0 to line# 0 to column# erase-screen ENDOF + bs OF column# 1- dup 0< IF + line# IF + line# 1- to line# + drop #columns 1- + ELSE drop column# + THEN + THEN + to column# ( bl draw-character ) + ENDOF + dup OF + i c@ draw-character + column# 1+ dup #columns >= IF + drop 0 terminal-line++ + THEN + to column# + ENDOF + ENDCASE + THEN + LOOP + restore-cursor +; diff --git a/src/roms/SLOF/slof/fs/timebase.fs b/src/roms/SLOF/slof/fs/timebase.fs new file mode 100644 index 0000000..00a0bd2 --- /dev/null +++ b/src/roms/SLOF/slof/fs/timebase.fs @@ -0,0 +1,24 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ Define all timebase related words + +: tb@ ( -- tb ) + BEGIN tbu@ tbl@ tbu@ rot over <> WHILE 2drop REPEAT + 20 lshift swap ffffffff and or +; + +: milliseconds ( -- ms ) tb@ d# 1000 * tb-frequency / ; +: microseconds ( -- us ) tb@ d# 1000000 * tb-frequency / ; + +: ms ( ms-to-wait -- ) milliseconds + BEGIN milliseconds over >= UNTIL drop ; +: get-msecs ( -- n ) milliseconds ; +: us ( us-to-wait -- ) microseconds + BEGIN microseconds over >= UNTIL drop ; diff --git a/src/roms/SLOF/slof/fs/translate.fs b/src/roms/SLOF/slof/fs/translate.fs new file mode 100644 index 0000000..9654f24 --- /dev/null +++ b/src/roms/SLOF/slof/fs/translate.fs @@ -0,0 +1,150 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ this is a C-to-Forth translation from the translate +\ address code in the client +\ with extensions to handle different sizes of #size-cells + +\ this tries to figure out if it is a PCI device what kind of +\ translation is wanted +\ if prop_type is 0, "reg" property is used, otherwise "assigned-addresses" +: pci-address-type ( node address prop_type -- type ) + -rot 2 pick ( prop_type node address prop_type ) + 0= IF + swap s" reg" rot get-property ( prop_type address data dlen false ) + ELSE + swap s" assigned-addresses" rot get-property ( prop_type address data dlen false ) + THEN + IF 2drop -1 EXIT THEN 4 / 5 / + \ advance (phys-addr(3) size(2)) steps + 0 DO + \ BARs and Expansion ROM must be in assigned-addresses... + \ so if prop_type is 0 ("reg") and a config space offset is set + \ we skip this entry... + dup l@ FF AND 0<> ( prop_type address data cfgspace_offset? ) + 3 pick 0= ( prop_type address data cfgspace_offset? reg_prop? ) + AND NOT IF + 2dup 4 + ( prop_type address data address data' ) + 2dup @ 2 pick 8 + @ + <= -rot @ >= and IF + l@ 03000000 and 18 rshift nip + ( prop_type type ) + swap drop ( type ) + UNLOOP EXIT + THEN + THEN + \ advance in 4 byte steps and (phys-addr(3) size(2)) steps + 4 5 * + + LOOP + 3drop -1 +; + +: (range-read-cells) ( range-addr #cells -- range-value ) + \ if number of cells != 1; do 64bit read; else a 32bit read + 1 = IF l@ ELSE @ THEN +; + +\ this functions tries to find a mapping for the given address +\ it assumes that if we have #address-cells == 3 that we are trying +\ to do a PCI translation + +\ nac - #address-cells +\ nsc - #size-cells +\ pnac - parent #address-cells + +: (map-one-range) ( type range pnac nsc nac address -- address true | address false ) + \ only check for the type if nac == 3 (PCI) + over 3 = 5 pick l@ 3000000 and 18 rshift 7 pick <> and IF + >r 2drop 3drop r> false EXIT + THEN + \ get size + 4 pick 4 pick 3 pick + 4 * + + \ get nsc + 3 pick + \ read size + ( type range pnac nsc nac address range nsc ) + (range-read-cells) + ( type range pnac nsc nac address size ) + \ skip type if PCI + 5 pick 3 pick 3 = IF + 4 + + THEN + \ get nac + 3 pick + ( type range pnac nsc nac address size range nac ) + \ read child-mapping + (range-read-cells) + ( type range pnac nsc nac address size child-mapping ) + dup >r dup 3 pick > >r + over <= r> or IF + \ address is not inside the mapping range + >r 2drop 3drop r> r> drop false EXIT + THEN + dup r> - + ( type range pnac nsc nac address offset ) + \ add the offset on the parent mapping + 5 pick 5 pick 3 = IF + \ skip type if PCI + 4 + + THEN + 3 pick 4 * + + ( type range pnac nsc nac address offset parent-mapping-address ) + \ get pnac + 5 pick + \ read parent mapping + (range-read-cells) + ( type range pnac nsc nac address offset parent-mapping ) + + >r 3drop 3drop r> true +; + +\ this word translates the given address starting from the node specified +\ in node; the word will return to the node it was started from +: translate-address ( node address -- address ) + \ check for address type in "assigned-addresses" + 2dup 1 pci-address-type ( node address type ) + dup -1 = IF + \ not found in "assigned-addresses", check in "reg" + drop 2dup 0 pci-address-type ( node address type ) + THEN + rot parent BEGIN + \ check if it is the root node + dup parent 0= IF 2drop EXIT THEN + ( address type parent ) + s" #address-cells" 2 pick get-property 2drop l@ >r \ nac + s" #size-cells" 2 pick get-property 2drop l@ >r \ nsc + s" #address-cells" 2 pick parent get-property 2drop l@ >r \ pnac + -rot ( node address type ) + s" ranges" 4 pick get-property IF + 3drop + ABORT" no ranges property; not translatable" + THEN + r> r> r> 3 roll + ( node address type ranges pnac nsc nac length ) + 4 / >r 3dup + + >r 5 roll r> r> swap / 0 ?DO + ( node type ranges pnac nsc nac address ) + 6dup (map-one-range) IF + nip leave + THEN + nip + \ advance ranges + 4 roll + ( node type pnac nsc nac address ranges ) + 4 pick 4 pick 4 pick + + 4 * + 4 -roll + LOOP + >r 2drop 2drop r> ( node type address ) + swap rot parent ( address type node ) + dup 0= + UNTIL +; + +\ this words translates the given address starting from the current node +: translate-my-address ( address -- address' ) + get-node swap translate-address +; diff --git a/src/roms/SLOF/slof/fs/update_flash.fs b/src/roms/SLOF/slof/fs/update_flash.fs new file mode 100644 index 0000000..e04869d --- /dev/null +++ b/src/roms/SLOF/slof/fs/update_flash.fs @@ -0,0 +1,110 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Set by update-flash -f to true, preventing update-flash -c +false value flash-new + +: update-flash-help ( -- ) + cr ." update-flash tool to flash host FW " cr + ." -f <filename> : Flash from file (e.g. net:\boot_rom.bin)" cr + ." -l : Flash from load-base" cr + ." -d : Flash from old load base (used by drone)" cr + ." -c : Flash from temp to perm" cr + ." -r : Flash from perm to temp" cr +; + +: flash-read-temp ( -- success? ) + get-flashside 1 = IF flash-addr get-load-base over flash-image-size rmove true + ELSE + false + THEN +; + +: flash-read-perm ( -- success? ) + get-flashside 0= IF + flash-addr get-load-base over flash-image-size rmove true + ELSE + false + THEN +; + +: flash-switch-side ( side -- success? ) + set-flashside 0<> IF + s" Cannot change flashside" type cr false + ELSE + true + THEN +; + +: flash-ensure-temp ( -- success? ) + get-flashside 0= IF + cr ." Cannot flash perm! Switching to temp side!" + 1 flash-switch-side + ELSE + true + THEN +; + +\ update-flash -f <filename> +\ -l +\ -c +\ -r + +: update-flash ( "text" ) + get-flashside >r \ Save old flashside + parse-word ( str len ) \ Parse first string + drop dup c@ ( str first-char ) + [char] - <> IF + update-flash-help r> 2drop EXIT + THEN + + 1+ c@ ( second-char ) + CASE + [char] f OF + parse-word cr s" do-load" evaluate + flash-ensure-temp TO flash-new + ENDOF + [char] l OF + flash-ensure-temp + ENDOF + [char] d OF + flash-load-base get-load-base 200000 move + flash-ensure-temp + ENDOF + [char] c OF + flash-read-temp 0= flash-new or IF + ." Cannot commit temp, need to boot on temp first " cr false + ELSE + 0 flash-switch-side + THEN + ENDOF + [char] r OF + flash-read-perm 0= IF + ." Cannot commit perm, need to boot on perm first " cr false + ELSE + 1 flash-switch-side + THEN + ENDOF + dup OF + false + ENDOF + ENDCASE + + ( true| false ) + + 0= IF + update-flash-help r> drop EXIT + THEN + + get-load-base flash-write 0= IF ." Flash write failed !! " cr THEN + r> set-flashside drop \ Restore old flashside +; diff --git a/src/roms/SLOF/slof/fs/usb/dev-hci.fs b/src/roms/SLOF/slof/fs/usb/dev-hci.fs new file mode 100644 index 0000000..5fb25b8 --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-hci.fs @@ -0,0 +1,71 @@ +\ ***************************************************************************** +\ * Copyright (c) 2006, 2012, 2013 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ +\ * +\ * [OEX]HCI functions +\ * +\ **************************************************************************** + +\ ( num $name type ) + +VALUE usb_type \ USB type + +\ Open Firmware Properties +device-type +" usb" 2dup device-name + +rot +VALUE usb_num \ controller number +usb_num $cathex strdup \ create alias name +2dup find-alias 0= IF + get-node node>path set-alias +ELSE 3drop THEN + +/hci-dev BUFFER: hcidev +usb_num hcidev usb-setup-hcidev +TRUE VALUE first-time-init? +0 VALUE open-count + +false VALUE dev-hci-debug? + +1 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + +\ converts physical address to text unit string +: encode-unit ( port -- unit-str unit-len ) 1 hex-encode-unit ; + +\ Converts text unit string to phyical address +: decode-unit ( addr len -- port ) 1 hex-decode-unit ; + +: get-hci-dev ( -- hcidev ) + hcidev +; + +: hc-cleanup ( -- ) + my-phandle set-node + dev-hci-debug? IF ." USB-HCI: Cleaning up " pwd cr THEN + hcidev USB-HCD-EXIT + 0 set-node +; + +: open ( -- true | false ) + true +; + +: close +; + +\ create a new entry to cleanup and suspend HCI +\ after first init +first-time-init? IF + ['] hc-cleanup add-quiesce-xt + false to first-time-init? +THEN diff --git a/src/roms/SLOF/slof/fs/usb/dev-hub.fs b/src/roms/SLOF/slof/fs/usb/dev-hub.fs new file mode 100644 index 0000000..ba0b334 --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-hub.fs @@ -0,0 +1,32 @@ +new-device + +VALUE sudev + +s" slofdev.fs" included +sudev slof-dev>port l@ dup set-unit encode-phys " reg" property +sudev slof-dev>udev @ VALUE udev + +s" hub" device-name + +s" dev-parent-calls.fs" included + +1 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property +: decode-unit 1 hex-decode-unit ; +: encode-unit 1 hex-encode-unit ; + +: usb-hub-init ( usbdev -- true | false ) + udev USB-HUB-INIT +; + +: open ( -- true | false ) + TRUE +; + +: close +; + +." USB HUB " cr +usb-hub-init drop + +finish-device diff --git a/src/roms/SLOF/slof/fs/usb/dev-keyb.fs b/src/roms/SLOF/slof/fs/usb/dev-keyb.fs new file mode 100644 index 0000000..db9e23e --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-keyb.fs @@ -0,0 +1,54 @@ +new-device + +VALUE sudev +false VALUE usb-keyb-debug? + +s" slofdev.fs" included +sudev slof-dev>port l@ dup set-unit encode-phys " reg" property +sudev slof-dev>udev @ VALUE udev + +s" usb-keyboard" device-name +s" keyboard" device-type +s" EN" encode-string s" language" property +s" keyboard" get-node node>path set-alias + +s" dev-parent-calls.fs" included + +0 VALUE open-count + +: open ( -- true | false ) + usb-keyb-debug? IF ." USB-KEYB: Opening (count is " open-count . ." )" cr THEN + open-count 0= IF + udev USB-HID-INIT 0= IF + ." USB keyboard setup failed " pwd cr false EXIT + THEN + THEN + open-count 1 + to open-count + true +; + +: close + usb-keyb-debug? IF ." USB-KEYB: Closing (count is " open-count . ." )" cr THEN + open-count 0> IF + open-count 1 - dup to open-count + 0= IF + my-phandle set-node + udev USB-HID-EXIT drop + 0 set-node + THEN + THEN +; + +\ method to check if a key is present in output buffer +\ used by 'term-io.fs' +: key-available? ( -- true|false ) + udev USB-KEY-AVAILABLE IF TRUE ELSE FALSE THEN +; + +: read ( addr len -- actual ) + 0= IF drop 0 EXIT THEN + udev USB-READ-KEYB ?dup IF swap c! 1 ELSE 0 swap c! 0 then +; + +." USB Keyboard " cr +finish-device diff --git a/src/roms/SLOF/slof/fs/usb/dev-mouse.fs b/src/roms/SLOF/slof/fs/usb/dev-mouse.fs new file mode 100644 index 0000000..f6acd7e --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-mouse.fs @@ -0,0 +1,20 @@ +new-device + +VALUE sudev +s" slofdev.fs" included +sudev slof-dev>port l@ dup set-unit encode-phys " reg" property +sudev slof-dev>udev @ VALUE udev + +s" usb-mouse" device-name + +\ .S cr +\ dup slof-dev>udev dup . @ . cr +\ dup slof-dev>port dup . l@ . cr +\ dup slof-dev>devaddr dup . l@ . cr +\ dup slof-dev>hcitype dup . l@ . cr +\ dup slof-dev>num dup . l@ . cr +\ dup slof-dev>devtype dup . l@ . cr + +." USB mouse " cr + +finish-device diff --git a/src/roms/SLOF/slof/fs/usb/dev-parent-calls.fs b/src/roms/SLOF/slof/fs/usb/dev-parent-calls.fs new file mode 100644 index 0000000..57fa8eb --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-parent-calls.fs @@ -0,0 +1,15 @@ +\ ****************************************************************************/ +\ * Copyright (c) 2011 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +get-node CONSTANT my-phandle + +s" dma-function.fs" included diff --git a/src/roms/SLOF/slof/fs/usb/dev-storage.fs b/src/roms/SLOF/slof/fs/usb/dev-storage.fs new file mode 100644 index 0000000..94f8421 --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/dev-storage.fs @@ -0,0 +1,361 @@ +\ ***************************************************************************** +\ * Copyright (c) 2013 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ ( usbdev -- ) + +new-device + +VALUE usbdev + +s" slofdev.fs" included + +false VALUE usb-disk-debug? + +usbdev slof-dev>port l@ dup set-unit encode-phys " reg" property +s" storage" device-name + +s" dev-parent-calls.fs" included + +2 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + +: decode-unit 2 hex64-decode-unit ; +: encode-unit 2 hex64-encode-unit ; + +0 CONSTANT USB_PIPE_OUT +1 CONSTANT USB_PIPE_IN + +\ ----------------------------------------------------------- +\ Specific properties +\ ----------------------------------------------------------- + +usbdev slof-dev>udev @ VALUE udev +usbdev slof-dev>port l@ VALUE port +usbdev slof-dev>hcitype l@ VALUE hcitype + +0 INSTANCE VALUE lun +10000 VALUE dev-max-transfer +0 VALUE resp-buffer +0 VALUE resp-size +0f CONSTANT SCSI-COMMAND-OFFSET + +\ ------------------------------------------------------- +\ DMA-able buffers +\ ------------------------------------------------------- + +STRUCT + dev-max-transfer FIELD usb>data + 40 FIELD usb>cmd + 20 FIELD usb>csw +CONSTANT /dma-buf + +0 VALUE dma-buf +0 VALUE dma-buf-phys +0 VALUE td-buf +0 VALUE td-buf-phys +1000 CONSTANT /td-buf + +: (dma-buf-init) ( -- ) + /dma-buf dma-alloc TO dma-buf + dma-buf /dma-buf 0 dma-map-in TO dma-buf-phys + /td-buf dma-alloc TO td-buf + td-buf /td-buf 0 dma-map-in TO td-buf-phys +; + +: (dma-buf-free) ( -- ) + td-buf td-buf-phys /td-buf dma-map-out + td-buf /td-buf dma-free + 0 TO td-buf + 0 TO td-buf-phys + dma-buf dma-buf-phys /dma-buf dma-map-out + dma-buf /dma-buf dma-free + 0 TO dma-buf + 0 TO dma-buf-phys +; + + +scsi-open + +\ ----------------------------------------------------------- +\ Perform SCSI commands +\ ----------------------------------------------------------- + +0 INSTANCE VALUE current-target + +\ SCSI command. We do *NOT* implement the "standard" execute-command +\ because that doesn't have a way to return the sense buffer back, and +\ we do have auto-sense with some hosts. Instead we implement a made-up +\ do-scsi-command. +\ +\ Note: stat is -1 for "hw error" (ie, error queuing the command or +\ getting the response). +\ +\ A sense buffer is returned whenever the status is non-0 however +\ if sense-len is 0 then no sense data is actually present +\ + +: do-bulk-command ( resp-buffer resp-size -- TRUE | FALSE ) + TO resp-size + TO resp-buffer + udev USB_PIPE_OUT td-buf td-buf-phys dma-buf-phys usb>cmd 1F + usb-transfer-bulk IF \ transfer CBW + resp-size IF + d# 125 us + udev USB_PIPE_IN td-buf td-buf-phys resp-buffer resp-size + usb-transfer-bulk 1 = not IF \ transfer data + usb-disk-debug? IF ." Data phase failed " cr THEN + \ FALSE EXIT + \ in case of a stall/halted endpoint we clear the halt + \ Fall through and try reading the CSW + THEN + THEN + d# 125 us + udev USB_PIPE_IN td-buf td-buf-phys dma-buf-phys usb>csw 0D + usb-transfer-bulk \ transfer CSW + ELSE + FALSE EXIT + THEN +; + +STRUCT \ cbw + /l FIELD cbw>sig + /l FIELD cbw>tag + /l FIELD cbw>len + /c FIELD cbw>flags + /c FIELD cbw>lun \ 0:3 bits + /c FIELD cbw>cblen \ 0:4 bits +CONSTANT cbw-length + +STRUCT \ csw + /l FIELD csw>sig + /l FIELD csw>tag + /l FIELD csw>data-residue + /c FIELD csw>status +CONSTANT cbw-length + +0 VALUE cbw-addr +0 VALUE csw-addr + +: build-cbw ( tag xfer-len dir lun cmd-len addr -- ) + TO cbw-addr ( tag xfer-len dir lun cmd-len ) + cbw-addr cbw-length erase ( tag xfer-len dir lun cmd-len ) + cbw-addr cbw>cblen c! ( tag xfer-len dir lun ) + cbw-addr cbw>lun c! ( tag xfer-len dir ) + \ dir is true or false + \ bmCBWFlags + \ BIT 7 Direction + \ 0 - OUT + \ 1 - IN + IF 80 ELSE 0 THEN + cbw-addr cbw>flags c! ( tag xfer-len ) + cbw-addr cbw>len l!-le ( tag ) + cbw-addr cbw>tag l!-le ( ) + 43425355 cbw-addr cbw>sig l!-le +; + +0 INSTANCE VALUE usb-buf-addr +0 INSTANCE VALUE usb-buf-len +0 INSTANCE VALUE usb-dir +0 INSTANCE VALUE usb-cmd-addr +0 INSTANCE VALUE usb-cmd-len +1 VALUE tag + +: execute-scsi-command ( buf-addr buf-len dir cmd-addr cmd-len -- ... ) + ( ... [ sense-buf sense-len ] stat ) + \ Cleanup virtio request and response + to usb-cmd-len to usb-cmd-addr to usb-dir to usb-buf-len to usb-buf-addr + + dma-buf usb>cmd 40 0 fill + dma-buf usb>csw 20 0 fill + + tag usb-buf-len usb-dir lun usb-cmd-len dma-buf usb>cmd + ( tag transfer-len dir lun cmd-len addr ) + build-cbw + 1 tag + to tag + + usb-cmd-addr + dma-buf usb>cmd SCSI-COMMAND-OFFSET + + usb-cmd-len + move + + \ Send it + dma-buf-phys usb>data usb-buf-len + do-bulk-command IF + dma-buf usb>data usb-buf-addr usb-buf-len move + ELSE + ." USB-DISK: Bulk commad failed!" cr + 0 0 -1 EXIT + THEN + + dma-buf usb>csw to csw-addr + csw-addr csw>sig l@ 55534253 <> IF + ." USB-DISK: CSW signature invalid " cr + 0 0 -1 EXIT + THEN + + csw-addr csw>status c@ CASE + 0 OF ENDOF \ Good + 1 OF + usb-disk-debug? IF + ." USB-DISK: CSW Data residue: " + csw-addr csw>data-residue l@-le . cr + THEN + 0 0 8 EXIT ENDOF \ Command failed, Retry + dup OF 0 0 -1 EXIT ENDOF \ Anything else -> HW error + ENDCASE + + \ Other error status + csw-addr csw>status c@ dup 0<> IF + usb-disk-debug? IF + over scsi-get-sense-data + ." USB-DISK: Sense key [ " dup . ." ] " .sense-text + ." ASC,ASCQ: " . . cr + THEN + rot + THEN +; + +\ -------------------------------- +\ Include the generic host helpers +\ -------------------------------- + +" scsi-host-helpers.fs" included + +0 VALUE open-count + +: usb-storage-init ( -- TRUE ) + td-buf 0= IF + usb-disk-debug? IF ." USB-DISK: Allocating buffer " cr THEN + (dma-buf-init) + udev USB-MSC-INIT 0= IF + ." USB-DISK: Unable to initialize MSC " cr + FALSE + ELSE + TRUE + THEN + THEN +; + +: usb-storage-cleanup + td-buf 0<> IF + usb-disk-debug? IF ." USB-DISK: Freeing buffer " cr THEN + (dma-buf-free) + udev USB-MSC-EXIT 0= IF ." USB-DISK: Unable to exit MSC " cr THEN + THEN +; + +: open + usb-disk-debug? IF ." USB-DISK: Opening (count is " open-count . ." )" cr THEN + + open-count 0= IF + usb-storage-init IF + 1 to open-count true + ELSE ." USB-DISK initialization failed !" cr false THEN + ELSE + open-count 1 + to open-count + true + THEN +; + +: close + usb-disk-debug? IF ." USB-DISK: Closing (count is " open-count . ." )" cr THEN + + open-count 0> IF + open-count 1 - dup to open-count + 0= IF + usb-storage-cleanup + THEN + THEN +; + +\ ----------------------------------------------------------- +\ SCSI scan at boot and child device support +\ ----------------------------------------------------------- + +\ We use SRP luns of the form 01000000 | (target << 8) | lun +\ in the top 32 bits of the 64-bit LUN +: (set-target) + dup 20 >> FFFF and to lun + dup 30 >> FF and to port + to current-target + usb-disk-debug? IF ." USB-DISK: udev " udev . ." lun:" lun . ." port:" port . cr THEN +; + +: dev-generate-srplun ( target lun-id -- srplun ) + swap drop port 0100 or 10 << or 20 << +; + +\ FIXME: Check max transfer coming from virtio config +: max-transfer ( -- n ) + dev-max-transfer +; + +\ We obtain here a unit address on the stack, since our #address-cells +\ is 2, the 64-bit srplun is split in two cells that we need to join +\ +\ Note: This diverges a bit from the original OF scsi spec as the two +\ cells are the 2 words of a 64-bit SRP LUN +: set-address ( srplun.lo srplun.hi -- ) + lxjoin (set-target) + usb-disk-debug? IF ." USB-DISK: udev " udev . ." lun:" lun . ." port:" port . cr THEN +; + +1 CONSTANT #target +: dev-max-target ( -- #target ) + #target +; + +" scsi-probe-helpers.fs" included + +scsi-close \ no further scsi words required + +\ Set scsi alias if none is set yet +: setup-alias + s" scsi" find-alias 0= IF + s" scsi" get-node node>path set-alias + ELSE + drop + THEN +; + +: usb-storage-init-and-scan ( -- ) + usb-disk-debug? IF ." Initializing usb-disk: udev " udev . cr THEN + + \ Create instance for scanning: + 0 0 get-node open-node ?dup 0= IF EXIT THEN + my-self >r + dup to my-self + + hcitype + CASE + 1 OF 4000 TO dev-max-transfer ENDOF \ OHCI + 2 OF 10000 TO dev-max-transfer ENDOF \ EHCI + 3 OF F000 TO dev-max-transfer ENDOF \ XHCI + ENDCASE + usb-storage-init + scsi-find-disks + setup-alias + usb-storage-cleanup + \ Close the temporary instance: + close-node + r> to my-self +; + +." USB Storage " cr +: usb-scsi-add-disk + " scsi-disk.fs" included +; + +usb-scsi-add-disk +usb-storage-init-and-scan + +finish-device diff --git a/src/roms/SLOF/slof/fs/usb/slofdev.fs b/src/roms/SLOF/slof/fs/usb/slofdev.fs new file mode 100644 index 0000000..d6e20fd --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/slofdev.fs @@ -0,0 +1,8 @@ +STRUCT + /n FIELD slof-dev>udev + /l FIELD slof-dev>port + /l FIELD slof-dev>devaddr + /l FIELD slof-dev>hcitype + /l FIELD slof-dev>num + /l FIELD slof-dev>devtype +CONSTANT slof-usb-dev diff --git a/src/roms/SLOF/slof/fs/usb/usb-static.fs b/src/roms/SLOF/slof/fs/usb/usb-static.fs new file mode 100644 index 0000000..47db727 --- /dev/null +++ b/src/roms/SLOF/slof/fs/usb/usb-static.fs @@ -0,0 +1,70 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2011, 2013 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +\ Load dev hci +: load-dev-hci ( num name-str name-len ) + s" dev-hci.fs" INCLUDED +; + +0 VALUE ohci-init +0 VALUE ehci-init +0 VALUE xhci-init +0 VALUE usb-alias-num + +: get-usb-alias-num + usb-alias-num dup 1+ to usb-alias-num +; + +\ create a new ohci device alias for the current node +: set-ohci-alias ( -- ) + 1 to ohci-init + get-usb-alias-num ( num ) + s" ohci" 1 load-dev-hci +; + +\ create a new ehci device alias for the current node +: set-ehci-alias ( -- ) + 1 to ehci-init + get-usb-alias-num ( num ) + s" ehci" 2 load-dev-hci +; + +\ create a new xhci device alias for the current node +: set-xhci-alias ( -- ) + 1 to xhci-init + get-usb-alias-num ( num ) + s" xhci" 3 load-dev-hci +; + +: usb-enumerate ( hcidev -- ) + USB-HCD-INIT +; + +: usb-scan ( -- ) + ." Scanning USB " cr + ohci-init 1 = IF USB-OHCI-REGISTER THEN + ehci-init 1 = IF USB-EHCI-REGISTER THEN + xhci-init 1 = IF USB-XHCI-REGISTER THEN + + usb-alias-num 0 ?DO + " usb" i $cathex find-device + " get-hci-dev" get-node find-method + IF + execute usb-enumerate + ELSE + ." get-base-address method not found for usb@" i . + ." Device type: " + " device_type" get-node get-property 0= IF decode-string type cr 2drop THEN + THEN + LOOP + 0 set-node \ FIXME Setting it back +; diff --git a/src/roms/SLOF/slof/fs/vpd-bootlist.fs b/src/roms/SLOF/slof/fs/vpd-bootlist.fs new file mode 100644 index 0000000..5a08215 --- /dev/null +++ b/src/roms/SLOF/slof/fs/vpd-bootlist.fs @@ -0,0 +1,134 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + +4 CONSTANT vpd-bootlist-size + +\ Bootable devices +00 CONSTANT FLOPPY +01 CONSTANT USB +02 CONSTANT SAS +03 CONSTANT SATA +04 CONSTANT ISCSI +05 CONSTANT ISCSICRITICAL +06 CONSTANT NET +07 CONSTANT NOTSPECIFIED +08 CONSTANT HDD0 +09 CONSTANT HDD1 +0a CONSTANT HDD2 +0b CONSTANT HDD3 +0c CONSTANT CDROM +0e CONSTANT HDD4 +10 CONSTANT SCSI + +: check-bootlist ( -- true | false ) + vpd-bootlist l@ + dup 0= IF + ( bootlist == 0 means that probably nothing from vpd has been received ) + s" Boot list could not be read from VPD" log-string cr + s" Boot watchdog has been rearmed" log-string cr + 2 set-watchdog + EXIT + THEN + + FFFFFFFF = IF + ( bootlist all FFs means that the vpd has no useful information ) + .banner + -6b boot-exception-handler + \ The next message is duplicate, but sent w. log-string + s" Boot list successfully read from VPD but no useful information received" log-string cr + s" Please specify the boot device in the management module" log-string cr + s" Specified Boot Sequence not valid" mm-log-warning + false + EXIT + THEN + + true +; + +\ the following words are necessary for vpd-boot-import +defer set-boot-device +defer add-boot-device + +\ select-install? is a flag which is used in the SMS panel #20 +\ "Select/Install Boot Devices". +\ This panel can be used to temporarily override the boot device. +false VALUE select-install? + +\ select/install-path stores string address and string length of the +\ device node chosen in the SMS panel #20 "Select/Install Boot Devices" +\ This device node is prepended to the boot path if select-install? is +\ true. +CREATE select/install-path 2 cells allot + +\ Import boot device list from VPD +\ If none, keep the existing list in NVRAM +\ This word can be used to overwrite read-bootlist if wanted + +: vpd-boot-import ( -- ) + 0 0 set-boot-device + + select-install? IF + select/install-path 2@ add-boot-device + THEN + + vpd-read-bootlist + check-bootlist IF + 4 0 DO vpd-bootlist i + c@ + CASE + 6 OF \ cr s" 2B Booting from Network" log-string cr + furnish-boot-file strdup add-boot-device + ENDOF + + HDD0 OF \ cr s" 2B Booting from hdd0" log-string cr + s" disk hdd0" add-boot-device ENDOF + + HDD1 OF \ cr s" 2B Booting from hdd1" log-string cr + s" hdd1" add-boot-device ENDOF + + HDD2 OF \ cr s" 2B Booting from hdd2" log-string cr + s" hdd2" add-boot-device ENDOF + + HDD3 OF \ cr s" 2B Booting from hdd3" log-string cr + s" hdd3" add-boot-device ENDOF + + CDROM OF \ cr s" 2B Booting from CDROM" log-string cr + s" cdrom" add-boot-device ENDOF + + HDD4 OF \ cr s" 2B Booting from hdd4" log-string cr + s" hdd4" add-boot-device ENDOF + + F OF \ cr s" 2B Booting from SAS - w. Timeout" log-string cr + s" sas" add-boot-device ENDOF + + SCSI OF \ cr s" 2B Booting from SAS - Continuous Retry" log-string cr + s" sas" add-boot-device ENDOF + + ENDCASE + LOOP + bootdevice 2@ nip + IF 0 + ELSE + \ Check for all no device -> use boot-device + vpd-bootlist l@ 07070707 = IF 0 ELSE -6b THEN + THEN + ELSE -6a THEN + boot-exception-handler +; + +: vpd-bootlist-restore-default ( -- ) + NOTSPECIFIED vpd-bootlist 0 + c! + NOTSPECIFIED vpd-bootlist 1 + c! + NOTSPECIFIED vpd-bootlist 2 + c! + HDD0 vpd-bootlist 3 + c! + vpd-write-bootlist +; + diff --git a/src/roms/SLOF/slof/fs/xmodem.fs b/src/roms/SLOF/slof/fs/xmodem.fs new file mode 100644 index 0000000..1221922 --- /dev/null +++ b/src/roms/SLOF/slof/fs/xmodem.fs @@ -0,0 +1,120 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +01 CONSTANT XM-SOH \ Start of header +04 CONSTANT XM-EOT \ End-of-transmission +06 CONSTANT XM-ACK \ Acknowledge +15 CONSTANT XM-NAK \ Neg. acknowledge + +0 VALUE xm-retries \ Retry count +0 VALUE xm-block# + + +\ * +\ * Internal function: +\ * wait <timeout> seconds for a new character +\ * +: xmodem-get-byte ( timeout -- byte|-1 ) + d# 1000 * + 0 DO + key? IF key UNLOOP EXIT THEN + 1 ms + LOOP + -1 +; + + +\ * +\ * Internal function: +\ * Receive one XMODEM packet, check block number and check sum. +\ * +: xmodem-rx-packet ( address -- success? ) + 1 xmodem-get-byte \ Get block number + dup 0 < IF + 2drop false EXIT \ Timeout + THEN + 1 xmodem-get-byte \ Get neg. block number + dup 0 < IF + 3drop false EXIT \ Timeout + THEN + rot 0 ( blk# ~blk# address chksum ) + 80 0 DO + 1 xmodem-get-byte dup 0 < IF ( blk# ~blk# address chksum byte ) + 3drop 2drop UNLOOP FALSE EXIT + THEN + dup 3 pick c! ( blk# ~blk# address chksum byte ) + + swap 1+ swap ( blk# ~blk# address+1 chksum' ) + LOOP + ( blk# ~blk# address chksum ) + \ Check sum: + 0ff and + 1 xmodem-get-byte <> IF + \ CRC failed! + 3drop FALSE EXIT + THEN + drop ( blk# ~blk# ) + \ finally check if block numbers are ok: + over xm-block# <> IF + \ Wrong block number! + 2drop FALSE EXIT + THEN ( blk# ~blk# ) + ff xor = +; + + +\ * +\ * Internal function: +\ * Load file to given address via XMODEM protocol +\ * +: (xmodem-load) ( address -- bytes ) + 1 to xm-block# + 0 to xm-retries + dup + BEGIN + d# 10 xmodem-get-byte dup >r + CASE + XM-SOH OF + dup xmodem-rx-packet IF + \ A packet has been received successfully + XM-ACK emit + 80 + ( start-addr next-addr R: rx-byte ) + 0 to xm-retries \ Reset retry count + xm-block# 1+ ff and to xm-block# \ Increase current block# + ELSE + \ Error while receiving packet + XM-NAK emit + xm-retries 1+ to xm-retries \ Increase retry count + THEN + ENDOF + XM-EOT OF + XM-ACK emit + ENDOF + dup OF + XM-NAK emit + xm-retries 1+ to xm-retries \ Increase retry count + ENDOF + ENDCASE + r> XM-EOT = + xm-retries d# 10 >= OR + UNTIL ( start-address end-address ) + swap - ( bytes received ) +; + + +\ * +\ * Load file to load-base via XMODEM protocol +\ * +: xmodem-load ( -- bytes ) + cr ." Waiting for start of XMODEM upload..." cr + get-load-base (xmodem-load) +; diff --git a/src/roms/SLOF/slof/helpers.c b/src/roms/SLOF/slof/helpers.c new file mode 100644 index 0000000..d7c1888b --- /dev/null +++ b/src/roms/SLOF/slof/helpers.c @@ -0,0 +1,136 @@ +/****************************************************************************** + * Copyright (c) 2007, 2012, 2013 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +/* + * All functions concerning interface to slof + */ + +#include <stdio.h> +#include <string.h> +#include <cpu.h> +#include "helpers.h" +#include "paflof.h" + +/** + * get msec-timer value + * access to HW register + * overrun will occur if boot exceeds 1.193 hours (49 days) + * + * @param - + * @return actual timer value in ms as 32bit + */ +uint32_t SLOF_GetTimer(void) +{ + forth_eval("get-msecs"); + return (uint32_t) forth_pop(); +} + +void SLOF_msleep(uint32_t time) +{ + time = SLOF_GetTimer() + time; + while (time > SLOF_GetTimer()) + cpu_relax(); +} + +void SLOF_usleep(uint32_t time) +{ + forth_push(time); + forth_eval("us"); +} + +void *SLOF_dma_alloc(long size) +{ + forth_push(size); + forth_eval("dma-alloc"); + return (void *)forth_pop(); +} + +void SLOF_dma_free(void *virt, long size) +{ + forth_push((long)virt); + forth_push(size); + forth_eval("dma-free"); +} + +void *SLOF_alloc_mem(long size) +{ + forth_push(size); + forth_eval("alloc-mem"); + return (void *)forth_pop(); +} + +void *SLOF_alloc_mem_aligned(long size, long align) +{ + unsigned long addr = (unsigned long)SLOF_alloc_mem(size + align - 1); + addr = addr + align - 1; + addr = addr & ~(align - 1); + + return (void *)addr; +} + +void SLOF_free_mem(void *addr, long size) +{ + forth_push((long)addr); + forth_push(size); + forth_eval("free-mem"); +} + +long SLOF_dma_map_in(void *virt, long size, int cacheable) +{ + forth_push((long)virt); + forth_push(size); + forth_push(cacheable); + forth_eval("dma-map-in"); + return forth_pop(); +} + +void SLOF_dma_map_out(long phys, void *virt, long size) +{ + forth_push((long)virt); + forth_push((long)phys); + forth_push(size); + forth_eval("dma-map-out"); +} + +long SLOF_pci_config_read32(long offset) +{ + forth_push(offset); + forth_eval("config-l@"); + return forth_pop(); +} + +long SLOF_pci_config_read16(long offset) +{ + forth_push(offset); + forth_eval("config-w@"); + return forth_pop(); +} + +void SLOF_pci_config_write32(long offset, long value) +{ + forth_push(value); + forth_push(offset); + forth_eval("config-l!"); +} + +void SLOF_pci_config_write16(long offset, long value) +{ + forth_push(value); + forth_push(offset); + forth_eval("config-w!"); +} + +void *SLOF_translate_my_address(void *addr) +{ + forth_push((long)addr); + forth_eval("translate-my-address"); + return (void *)forth_pop(); +} diff --git a/src/roms/SLOF/slof/lowmem.S b/src/roms/SLOF/slof/lowmem.S new file mode 100644 index 0000000..9aaa9f7 --- /dev/null +++ b/src/roms/SLOF/slof/lowmem.S @@ -0,0 +1,69 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +#include <cpu.h> +#include <xvect.h> + + .globl _start + /* All exception vectors *******************/ +_start: + .org 0x100 + /* check if Master / Slave *****************/ + /* Master will go to XVECT_M_HANDLER */ + /* Slave will go to XVECT_S_HANDLER */ +#ifdef SECONDARY_CPUS_STOPPED + ld r3,XVECT_S_HANDLER(0) + mfspr r0, PIR + cmpwi r0, 0 + bne 0f +#endif + ld r3,XVECT_M_HANDLER(0) +0: + mtctr r3 + li r0,0x100 + bctr + + /* FIXME: Also need 0280, 0380, 0f20, etc. */ + + .irp i, 0x0200,0x0280,0x0300,0x0380,0x0400,0x0480,0x0500,0x0600,0x0700, \ + 0x0800,0x0900,0x0a00,0x0b00,0x0c00,0x0d00,0x0e00,0x0f00, \ + 0x1000,0x1100,0x1200,0x1300,0x1400,0x1500,0x1600,0x1700, \ + 0x1800,0x1900,0x1a00,0x1b00,0x1c00,0x1d00,0x1e00,0x1f00, \ + 0x2000,0x2100,0x2200,0x2300,0x2400,0x2500,0x2600,0x2700, \ + 0x2800,0x2900,0x2a00,0x2b00,0x2c00,0x2d00,0x2e00,0x2f00 + .org \i + + /* enable this if you get exceptions before the console works */ + /* this will allow using the hardware debugger to see where */ + /* it traps, and with what register values etc. */ + // b $ + + mtsprg 0,r0 + mfctr r0 + mtsprg 2,r0 + mflr r0 + mtsprg 3,r0 + ld r0, XVECT_M_HANDLER(0) + mtctr r0 + li r0,\i + bctr + .endr + + + .org XVECT_M_HANDLER + .quad 0 + + .org XVECT_S_HANDLER + .quad 0 + + .org XVECT_TOPADDR + .byte 0x36 # to fill out to exactly 16kB diff --git a/src/roms/SLOF/slof/ofw.S b/src/roms/SLOF/slof/ofw.S new file mode 100644 index 0000000..14e1e9d --- /dev/null +++ b/src/roms/SLOF/slof/ofw.S @@ -0,0 +1,59 @@ +/****************************************************************************** + * Copyright (c) 2004, 2011 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +#include <cpu.h> +#include <xvect.h> + + .section ".slof.loader","ax" + + /* this only works if paflof is running below 4GB */ + lis r31, fdt_start@h /* save address of */ + ori r31, r31, fdt_start@l /* flattened device */ + std r3, 0(r31) /* tree */ + + /* this only works if paflof is running below 4GB */ + lis r31, romfs_base@h /* save address of */ + ori r31, r31, romfs_base@l /* the romfs */ + std r4, 0(r31) + + /* this only works if paflof is running below 4GB */ + lis r31, epapr_magic@h /* if it is an epapr compliant */ + ori r31, r31, epapr_magic@l /* low level firmware; then r6 */ + std r6, 0(r31) /* contains the epapr magic */ + + /* this only works if paflof is running below 4GB */ + lis r31, epapr_ima_size@h + ori r31, r31, epapr_ima_size@l + std r7, 0(r31) /* r7 contains the IMA size */ + + /* fill in handler address */ + + /* this only works if paflof is running below 4GB */ + mfmsr r0 + mtsrr1 r0 + lis r3, _slof_text@h + ori r3, r3, _slof_text@l + ld r3, 0(r3) + std r3, XVECT_M_HANDLER(0) + +#ifdef BROKEN_SC1 + /* Patch potentially broken sc 1 instructions */ + lis r3, _slof_text@h + ori r3, r3, _slof_text@l + lis r4, _slof_text_end@h + ori r4, r4, _slof_text_end@l + li r5, 0 + bl .patch_broken_sc1 +#endif + + /* GO! */ + ba 0x100 diff --git a/src/roms/SLOF/slof/paflof.c b/src/roms/SLOF/slof/paflof.c new file mode 100644 index 0000000..624955f --- /dev/null +++ b/src/roms/SLOF/slof/paflof.c @@ -0,0 +1,116 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + + +#define XSTR(x) #x +#define ISTR(x,y) XSTR(x.y) +#undef unix + +#include "paflof.h" +#include <string.h> +#include <stdint.h> +#include <ctype.h> +#include <cache.h> +#include <allocator.h> + +#include ISTR(TARG,h) + +#define LAST_ELEMENT(x) x[sizeof x / sizeof x[0] - 1] + +/* Hack to get around static inline issues */ +#include "../lib/libhvcall/libhvcall.h" + + +extern char _start_OF[]; + +unsigned long fdt_start; +unsigned long romfs_base; +unsigned long epapr_magic; +unsigned long epapr_ima_size; // ePAPR initially mapped area size +unsigned char hash_table[HASHSIZE*CELLSIZE]; + +#include ISTR(TARG,c) + +// the actual engine +long engine(int mode, long param_1, long param_2) +{ + // For Exceptions: + // mode = ENGINE_MODE_PARAM_1 | MODE_PARAM_2 + // (param_1 = error, param_2 = reason) + // + // For Push: + // mode = ENGINE_MODE_PARAM_1 | ENGINE_MODE_NOP + // + // For Pop: + // mode = ENGINE_MODE_NOP | ENGINE_MODE_POP + // + // For Evaluate: + // mode = ENGINE_MODE_PARAM_1 | MODE_PARAM_2 | ENGINE_MODE_EVAL + // (param_1 = strlen(string), param_2 = string) + + cell *restrict ip; + cell *restrict cfa; + static cell handler_stack[160]; + static cell c_return[2]; + static cell dummy; + + #include "prep.h" + #include "dict.xt" + + static int init_engine = 0; + if (init_engine == 0) { + // one-time initialisation + init_engine = 1; + LAST_ELEMENT(xt_FORTH_X2d_WORDLIST).a = xt_LASTWORD; + + // stack-pointers + dp = the_data_stack - 1; + rp = handler_stack - 1; + + // return-address for "evaluate" personality + dummy.a = &&over; + c_return[1].a = &dummy; + } + + if (mode & ENGINE_MODE_PARAM_2) { + (++dp)->n = param_2; + } + if (mode & ENGINE_MODE_PARAM_1) { + (++dp)->n = param_1; + } + + if (mode & ENGINE_MODE_NOP ) { + goto over; + } + + if (mode & ENGINE_MODE_EVAL) { + (++rp)->a = c_return; + ip = xt_EVALUATE + 2 + ((10 + CELLSIZE - 1) / CELLSIZE); + } else { + ip = xt_SYSTHROW; + } + + #include "prim.code" + #include "board.code" + #include ISTR(TARG,code) + + + // Only reached in case of non-exception call +over: if (mode & ENGINE_MODE_POP) { + return ((dp--)->n); + } else { + return 0; + } +} diff --git a/src/roms/SLOF/slof/paflof.h b/src/roms/SLOF/slof/paflof.h new file mode 100644 index 0000000..885c948 --- /dev/null +++ b/src/roms/SLOF/slof/paflof.h @@ -0,0 +1,41 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + + +extern long engine(int, long, long); + +#define TIBSIZE 256 + +#define POCKETSIZE 256 +#define NUMPOCKETS 16 + +#define HASHSIZE 0x1000 + +// engine mode bits +#define ENGINE_MODE_PARAM_1 0x0001 +#define ENGINE_MODE_PARAM_2 0x0002 +#define ENGINE_MODE_NOP 0x0004 +#define ENGINE_MODE_EVAL 0x0008 +#define ENGINE_MODE_POP 0x0010 + +// engine calls +#define forth_eval(s) engine(ENGINE_MODE_PARAM_1|ENGINE_MODE_PARAM_2|ENGINE_MODE_EVAL, \ + strlen((s)), (long)(s)) +#define forth_eval_pop(s) engine(ENGINE_MODE_PARAM_1|ENGINE_MODE_PARAM_2|ENGINE_MODE_EVAL|ENGINE_MODE_POP, \ + strlen((s)), (long)(s)) + +#define forth_push(v) engine(ENGINE_MODE_PARAM_1|ENGINE_MODE_NOP, v, 0) + +#define forth_pop() engine(ENGINE_MODE_NOP|ENGINE_MODE_POP, 0, 0) diff --git a/src/roms/SLOF/slof/ppc64.c b/src/roms/SLOF/slof/ppc64.c new file mode 100644 index 0000000..619d95e --- /dev/null +++ b/src/roms/SLOF/slof/ppc64.c @@ -0,0 +1,93 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +#include <cpu.h> + +/* the exception frame should be page aligned + * the_exception_frame is used by the handler to store a copy of all + * registers after an exception; this copy can then be used by paflof's + * exception handler to printout a register dump */ +cell the_exception_frame[0x400 / CELLSIZE] __attribute__ ((aligned(PAGE_SIZE)));; + +/* the_client_frame is the register save area when starting a client */ +cell the_client_frame[0x1000 / CELLSIZE] __attribute__ ((aligned(0x100))); +cell the_client_stack[0x8000 / CELLSIZE] __attribute__ ((aligned(0x100))); +/* THE forth stack */ +cell the_data_stack[0x2000 / CELLSIZE] __attribute__ ((aligned(0x100))); +/* the forth return stack */ +cell the_return_stack[0x2000 / CELLSIZE] __attribute__ ((aligned(0x100))); + +/* forth stack and return-stack pointers */ +cell *restrict dp; +cell *restrict rp; + +/* terminal input buffer */ +cell the_tib[0x1000 / CELLSIZE] __attribute__ ((aligned(0x100))); +/* temporary string buffers */ +char the_pockets[NUMPOCKETS * POCKETSIZE] __attribute__ ((aligned(0x100))); + +cell the_comp_buffer[0x1000 / CELLSIZE] __attribute__ ((aligned(0x100))); + +cell the_heap[HEAP_SIZE / CELLSIZE] __attribute__ ((aligned(0x1000))); +cell *the_heap_start = &the_heap[0]; +cell *the_heap_end = &the_heap[HEAP_SIZE / CELLSIZE]; + +extern void io_putchar(unsigned char); +extern unsigned long call_c(cell arg0, cell arg1, cell arg2, cell entry); + + +long +writeLogByte_wrapper(long x, long y) +{ + unsigned long result; + + SET_CI; + result = writeLogByte(x, y); + CLR_CI; + + return result; +} + + +/** + * Standard write function for the libc. + * + * @param fd file descriptor (should always be 1 or 2) + * @param buf pointer to the array with the output characters + * @param count number of bytes to be written + * @return the number of bytes that have been written successfully + */ +int +write(int fd, const void *buf, int count) +{ + int i; + char *ptr = (char *)buf; + + if (fd != 1 && fd != 2) + return 0; + + for (i = 0; i < count; i++) { + if (*ptr == '\n') + io_putchar('\r'); + io_putchar(*ptr++); + } + + return i; +} + +/* This should probably be temporary until a better solution is found */ +void +asm_cout(long Character, long UART, long NVRAM __attribute__((unused))) +{ + if (UART) + io_putchar(Character); +} diff --git a/src/roms/SLOF/slof/ppc64.code b/src/roms/SLOF/slof/ppc64.code new file mode 100644 index 0000000..94069a2 --- /dev/null +++ b/src/roms/SLOF/slof/ppc64.code @@ -0,0 +1,274 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + + +// This file contains the implementation of the Forth code words specific +// to PowerPC64. Some of this is 970-only. + +// 970-specific CPU registers. +// Don't use on P7 ! +PRIM(HID0_X21) + unsigned long hid0 = TOS.u; + asm volatile("sync ; mtspr 1008,%0 ; mfspr %0,1008 ; mfspr %0,1008 ; mfspr %0,1008 ; mfspr %0,1008 ; mfspr %0,1008 ; mfspr %0,1008" : "+r"(hid0)); + POP; +MIRP + +PRIM(HID0_X40) + PUSH; + asm volatile("mfspr %0,1008" : "=r"(TOS)); +MIRP + +PRIM(HID1_X21) + unsigned long hid1 = TOS.u; + asm volatile("mtspr 1009,%0 ; mtspr 1009,%0 ; isync" : : "r"(hid1)); + POP; +MIRP + +PRIM(HID1_X40) + PUSH; + asm volatile("mfspr %0,1009" : "=r"(TOS)); +MIRP + +PRIM(HID4_X21) + unsigned long hid4 = TOS.u; + asm volatile("sync ; mtspr 1012,%0 ; isync" : : "r"(hid4)); + POP; +MIRP + +PRIM(HID4_X40) + PUSH; + asm volatile("mfspr %0,1012" : "=r"(TOS)); +MIRP + +PRIM(HID5_X21) + unsigned long hid5 = TOS.u; + asm volatile("mtspr 1014,%0" : : "r"(hid5)); + POP; +MIRP + +PRIM(HID5_X40) + PUSH; + asm volatile("mfspr %0,1014" : "=r"(TOS)); +MIRP + +// PowerPC special registers. +PRIM(MSR_X21) + unsigned long msr = TOS.u; + asm volatile("mtmsrd %0" : : "r"(msr)); + POP; +MIRP + +PRIM(MSR_X40) + PUSH; + asm volatile("mfmsr %0" : "=r"(TOS)); +MIRP + +PRIM(SDR1_X21) + unsigned long sdr1 = TOS.u; + asm volatile("mtsdr1 %0" : : "r"(sdr1)); + POP; +MIRP + +PRIM(SDR1_X40) + PUSH; + asm volatile("mfsdr1 %0" : "=r"(TOS)); +MIRP + +PRIM(PVR_X40) + PUSH; + asm volatile("mfpvr %0" : "=r"(TOS)); +MIRP + +PRIM(PIR_X40) + PUSH; + asm volatile("mfspr %0,1023" : "=r"(TOS)); +MIRP + +PRIM(TBL_X40) + PUSH; + asm volatile("mftbl %0" : "=r"(TOS)); +MIRP + +PRIM(TBU_X40) + PUSH; + asm volatile("mftbu %0" : "=r"(TOS)); +MIRP + +PRIM(DABR_X21) + unsigned long dabr = TOS.u; + asm volatile("mtspr 1013,%0" : : "r"(dabr)); + POP; +MIRP + +PRIM(DABR_X40) + PUSH; + asm volatile("mfspr %0,1013" : "=r"(TOS)); +MIRP + +PRIM(HIOR_X21) + unsigned long dabr = TOS.u; + asm volatile("mtspr 311,%0" : : "r"(dabr)); + POP; +MIRP + +PRIM(HIOR_X40) + PUSH; + asm volatile("mfspr %0,311" : "=r"(TOS)); +MIRP + + + +PRIM(SPRG0_X21) + unsigned long sprg0 = TOS.u; + asm volatile("mtsprg0 %0" : "+r"(sprg0)); + POP; +MIRP + +PRIM(SPRG0_X40) + PUSH; + asm volatile("mfsprg0 %0" : "=r"(TOS)); +MIRP + +PRIM(SPRG1_X21) + unsigned long sprg1 = TOS.u; + asm volatile("mtsprg1 %0" : "+r"(sprg1)); + POP; +MIRP + +PRIM(SPRG1_X40) + PUSH; + asm volatile("mfsprg1 %0" : "=r"(TOS)); +MIRP + +PRIM(SPRG2_X21) + unsigned long sprg2 = TOS.u; + asm volatile("mtsprg2 %0" : "+r"(sprg2)); + POP; +MIRP + +PRIM(SPRG2_X40) + PUSH; + asm volatile("mfsprg2 %0" : "=r"(TOS)); +MIRP + +PRIM(SPRG3_X21) + unsigned long sprg3 = TOS.u; + asm volatile("mtsprg3 %0" : "+r"(sprg3)); + POP; +MIRP + +PRIM(SPRG3_X40) + PUSH; + asm volatile("mfsprg3 %0" : "=r"(TOS)); +MIRP + +PRIM(HSPRG0_X21) + unsigned long hsprg0 = TOS.u; + asm volatile("mtspr 304,%0" : "+r"(hsprg0)); + POP; +MIRP + +PRIM(HSPRG0_X40) + PUSH; + asm volatile("mfspr %0,304" : "=r"(TOS)); +MIRP + +PRIM(HSPRG1_X21) + unsigned long hsprg1 = TOS.u; + asm volatile("mtspr 305,%0" : "+r"(hsprg1)); + POP; +MIRP + +PRIM(HSPRG1_X40) + PUSH; + asm volatile("mfspr %0,305" : "=r"(TOS)); +MIRP + + +PRIM(MMCR0_X21) + unsigned long mmcr0 = TOS.u; + asm volatile("sync ; mtspr 795,%0 ; isync" : : "r"(mmcr0)); + POP; +MIRP + +PRIM(PMC1_X40) + PUSH; + asm volatile("sync ; mfspr %0,787" : "=r"(TOS)); +MIRP + +PRIM(ICBI) + asm volatile("dcbst 0,%0 ; sync ; icbi 0,%0 ; sync ; isync" : : "r"(TOS)); + POP; +MIRP + +// Call into the client program. +PRIM(JUMP_X2d_CLIENT) + TOS.u = call_client(TOS); +MIRP + + +// Hang. Useful for debugging, believe it or not. +PRIM(CRASH) + for (;;) ; +MIRP + +PRIM(START_X2d_RTAS) + cell e = TOS; POP; + cell p1 = TOS; POP; + cell p0 = TOS; + TOS.u = call_c(p0, p1, (cell)0UL, e); +MIRP + +PRIM(CALL_X2d_C) + cell e = TOS; POP; + cell p2 = TOS; POP; + cell p1 = TOS; POP; + cell p0 = TOS; + TOS.u = call_c(p0, p1, p2, e); +MIRP + +PRIM(FLUSHCACHE) + type_u n = TOS.u; POP; + unsigned char* p = TOS.a; POP; + flush_cache(p, n); +MIRP + +PRIM(DEC_X21) + unsigned long dec = TOS.u; + asm volatile("mtdec %0" : "+r"(dec)); + POP; +MIRP + +PRIM(DEC_X40) + PUSH; + asm volatile("mfdec %0" : "=r"(TOS)); +MIRP + +PRIM(BM_X2d_ALLOCATOR_X2d_INIT) + unsigned long blocksize = TOS.u; POP; + unsigned long size = TOS.u; POP; + unsigned long start = TOS.u; + TOS.u = SLOF_bm_allocator_init(start, size, blocksize); +MIRP + +PRIM(BM_X2d_ALLOC) + unsigned long size = TOS.u; POP; + unsigned long handle = TOS.u; + TOS.u = SLOF_bm_alloc(handle, size); +MIRP + +PRIM(BM_X2d_FREE) + unsigned long size = TOS.u; POP; + unsigned long addr = TOS.u; POP; + unsigned long handle = TOS.u; POP; + SLOF_bm_free(handle, addr, size); +MIRP
\ No newline at end of file diff --git a/src/roms/SLOF/slof/ppc64.h b/src/roms/SLOF/slof/ppc64.h new file mode 100644 index 0000000..59a1b90 --- /dev/null +++ b/src/roms/SLOF/slof/ppc64.h @@ -0,0 +1,41 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +#include <cpu.h> +#include "types.h" + +#define PAGE_SIZE 4096 +#define HEAP_SIZE 0x800000 + +#ifdef CPU_PPC970 +#define SET_CI set_ci() +#define CLR_CI clr_ci() +#else +#define SET_CI +#define CLR_CI +#endif + +// The big Forth source file that contains everything but the core engine. +// We include it as a hunk of data into the C part of SLOF; at startup +// time, this will be EVALUATE'd. +extern char _binary_OF_fsi_start[], _binary_OF_fsi_end[]; + +extern cell the_mem[]; /* Space for the dictionary / the HERE pointer */ + +extern cell *restrict dp; +extern cell *restrict rp; + +void client_entry_point(); + +extern unsigned long call_client(cell); +extern long c_romfs_lookup(long, long, void *); +extern long writeLogByte(long, long); diff --git a/src/roms/SLOF/slof/ppc64.in b/src/roms/SLOF/slof/ppc64.in new file mode 100644 index 0000000..b533c68 --- /dev/null +++ b/src/roms/SLOF/slof/ppc64.in @@ -0,0 +1,96 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +// The Forth code words (primitives) that are specific to PowerPC64. + +// CPU register accesses. +cod(HID0!) +cod(HID0@) +cod(HID1!) +cod(HID1@) +cod(HID4!) +cod(HID4@) +cod(HID5!) +cod(HID5@) +cod(MSR@) +cod(MSR!) +cod(SDR1@) +cod(SDR1!) +cod(PVR@) +cod(PIR@) +cod(TBL@) +cod(TBU@) +cod(DABR@) +cod(DABR!) +cod(HIOR@) +cod(HIOR!) +cod(SPRG0@) +cod(SPRG0!) +cod(SPRG1@) +cod(SPRG1!) +cod(SPRG2@) +cod(SPRG2!) +cod(SPRG3@) +cod(SPRG3!) +cod(HSPRG0@) +cod(HSPRG0!) +cod(HSPRG1@) +cod(HSPRG1!) +cod(DEC@) +cod(DEC!) + +cod(MMCR0!) +cod(PMC1@) + +cod(ICBI) + + +// The start address of a binary payload. +//con(PAYLOAD (type_u)_binary_payload_start) + +// Calling the client program. +con(CLIENT-ENTRY-POINT (type_u)client_entry_point) +cod(JUMP-CLIENT) +dfr(CLIENTINTERFACE) + + +con(ROMFS-LOOKUP-ENTRY (type_u) c_romfs_lookup) + +// not very elegant... but the only way it works for me +con(.WRITE-LOG-BYTE-ENTRY (type_u) writeLogByte_wrapper) +col(WRITE-LOG-BYTE-ENTRY .WRITE-LOG-BYTE-ENTRY @) + +cod(CALL-C) +cod(START-RTAS) + + +cod(FLUSHCACHE) +// Bit map allocator +cod(BM-ALLOCATOR-INIT) +cod(BM-ALLOC) +cod(BM-FREE) + +// Hang. +cod(CRASH) + +var(DAAR 0x00f00000) +col(DUMBER DAAR @ C! LIT(1) DAAR +!) + +dfr(BOOT-EXCEPTION-HANDLER) + +col(NICEINIT DOTICK DROP DOTO EMIT DOTICK ((FIND)) DOTO (FIND) DOTICK 2DROP DOTO (REVEAL) LIT((type_u)_binary_OF_fsi_start) LIT((type_u)_binary_OF_fsi_end) OVER - DOTICK EVALUATE CATCH BOOT-EXCEPTION-HANDLER) + +static cell xt_SYSTHROW[] = { _0 RDEPTH_X21 DUP LIT(0x100) _X3d _0BRANCH(5) SWAP DROP NICEINIT BRANCH(7) DUP LIT(0x3800) _X3d _0BRANCH(1) CLIENTINTERFACE PRINT_X2d_STATUS QUIT }; + +// sentinel, leave it here! +col(LASTWORD ) + diff --git a/src/roms/SLOF/slof/prep.h b/src/roms/SLOF/slof/prep.h new file mode 100644 index 0000000..03950ba --- /dev/null +++ b/src/roms/SLOF/slof/prep.h @@ -0,0 +1,46 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + + +#define _N(_n) { .n = _n }, +#define _O(_n) { .n = CELLSIZE * (_n) }, +#define _C(_c) { .c = _c }, +#define _A(_a) { .a = _a }, + +#define ref(_xt, _nname) _A(xt_ ## _xt + _nname) +#define header(_xt, _header...) static cell xt_ ## _xt[] = { _header +#define def(_xts...) _xts }; +#define lab(_xt) _A(&&code_ ## _xt) + +#define DOCOL lab(DOCOL) +#define DODOES lab(DODOES) +#define DODEFER lab(DODEFER) +#define DOALIAS lab(DOALIAS) +#define DOCON lab(DOCON) +#define DOVAL lab(DOVAL) +#define DOFIELD lab(DOFIELD) +#define DOVAR lab(DOVAR) +#define DOBUFFER_X3a lab(DOBUFFER_X3a) + +#define cod(_xt) def(lab(_xt)) +#define col(_xt, _def...) def(DOCOL _def SEMICOLON) +#define con(_xt, _def) def(DOCON _N(_def)) +#define dfr(_xt) def(DODEFER _N(0)) +#define val(_xt, _def) def(DOVAL _N(_def)) +#define var(_xt, _def) def(DOVAR _N(_def)) + + +#define raw(_xt, _def) def(_def) +#define str(_xt, _def...) def(_def) diff --git a/src/roms/SLOF/slof/prim.code b/src/roms/SLOF/slof/prim.code new file mode 100644 index 0000000..bb9e036 --- /dev/null +++ b/src/roms/SLOF/slof/prim.code @@ -0,0 +1,605 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + + +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + + +#define NEXT00 goto *cfa->a +#define NEXT0 cfa = ip->a; NEXT00 +#define NEXT ip++; NEXT0 + +#define PRIM(name) code_##name: { \ + asm volatile ("#### " #name : : : "memory"); \ + void *w = (cfa = (++ip)->a)->a; +#define MIRP goto *w; } + + + + // start interpreting + NEXT0; + + + +// These macros could be replaced to allow for TOS caching etc. +#define TOS (*dp) +#define NOS (*(dp-1)) +#define POP dp-- +#define PUSH dp++ + +#define RTOS (*rp) +#define RNOS (*(rp-1)) +#define RPOP rp-- +#define RPUSH rp++ + + + + +// For terminal input. +PRIM(TIB) PUSH; TOS.a = the_tib; MIRP + +// For pockets (temporary string buffers). +PRIM(POCKETS) PUSH; TOS.a = the_pockets; MIRP + +// exception register area +PRIM(EREGS) PUSH; TOS.a = the_exception_frame; MIRP + +// client register area +PRIM(CIREGS) PUSH; TOS.a = the_client_frame; MIRP + +// Client stack +// (According to the PowerPC ABI the stack-pointer points to the +// lowest **USED** value. +// I.e. it is decremented before a new element is stored on the +// stack.) +PRIM(CISTACK) PUSH; TOS.a = the_client_stack + + (sizeof(the_client_stack) / CELLSIZE); MIRP + +// compile-in-interpret buffer +PRIM(COMP_X2d_BUFFER) PUSH; TOS.a = the_comp_buffer; MIRP + +// Paflof base address +PRIM(PAFLOF_X2d_START) PUSH; TOS.a = _start_OF; MIRP + +// Heap pointers +PRIM(HEAP_X2d_START) PUSH; TOS.a = the_heap_start; MIRP +PRIM(HEAP_X2d_END) PUSH; TOS.a = the_heap_end; MIRP + +// FDT pointer +PRIM(FDT_X2d_START) PUSH; TOS.u = fdt_start; MIRP + +// romfs-base +PRIM(ROMFS_X2d_BASE) PUSH; TOS.u = romfs_base; MIRP + +// if the low level firmware is epapr compliant it will put the +// epapr magic into r6 before starting paflof +// epapr-magic is a copy of r6 +PRIM(EPAPR_X2d_MAGIC) PUSH; TOS.u = epapr_magic; MIRP + +// Initially mapped area size (for ePAPR compliant LLFW) +PRIM(EPAPR_X2d_IMA_X2d_SIZE) PUSH; TOS.u = epapr_ima_size; MIRP + +// Codefields. +code_DOCOL: + { + RPUSH; RTOS.a = ip; + ip = cfa; + NEXT; + } +code_DODOES: + { + RPUSH; RTOS.a = ip; + ip = (cfa + 1)->a; + PUSH; TOS.a = cfa + 2; + NEXT0; + } +code_DODEFER: + { + cfa = (cfa + 1)->a; + NEXT00; + } +code_DOALIAS: + { + cfa = (cfa + 1)->a; + NEXT00; + } +code_DOCON: + { + PUSH; + TOS = *(cfa + 1); + NEXT; + } +code_DOVAL: + { + PUSH; + TOS = *(cfa + 1); + NEXT; + } +code_DOFIELD: + { + dp->n += (cfa + 1)->n; + NEXT; + } +code_DOVAR: + { + (++dp)->a = cfa + 1; + NEXT; + } +code_DOBUFFER_X3a: + { + (++dp)->a = cfa + 1; + NEXT; + } + + + + + +// branching +code_BRANCH: + { + type_n dis = (++ip)->n; + ip = (cell *)((type_u)ip + dis); + NEXT; + } +code_0BRANCH: + { + type_n dis = (++ip)->n; + if (TOS.u == 0) + ip = (cell *)((type_u)ip + dis); + POP; + NEXT; + } + +// Jump to "defer BP" +code_BREAKPOINT: + { + RPUSH; RTOS.a = ip; + ip = (cell * ) xt_BP+2; + NEXT; + } + + +// literals +code_LIT: + { + PUSH; + TOS = *++ip; + NEXT; + } +code_DOTICK: + { + PUSH; + TOS = *++ip; + NEXT; + } + + + +// 1.1 +PRIM(DUP) cell x = TOS; PUSH; TOS = x; MIRP +PRIM(OVER) cell x = NOS; PUSH; TOS = x; MIRP +PRIM(PICK) TOS = *(dp - TOS.n - 1); MIRP + +// 1.2 +PRIM(DROP) POP; MIRP + +// 1.3 +PRIM(SWAP) cell x = NOS; NOS = TOS; TOS = x; MIRP + +// 1.4 +PRIM(_X3e_R) RPUSH; RTOS = TOS; POP; MIRP +PRIM(R_X3e) PUSH; TOS = RTOS; RPOP; MIRP +PRIM(R_X40) PUSH; TOS = RTOS; MIRP + +// 1.5 +PRIM(DEPTH) PUSH; TOS.u = dp - the_data_stack; MIRP +PRIM(DEPTH_X21) dp = the_data_stack + TOS.u - 1; MIRP +PRIM(RDEPTH) PUSH; TOS.u = rp - the_return_stack + 1; MIRP +PRIM(RDEPTH_X21) rp = the_return_stack + TOS.u - 1; POP; MIRP +PRIM(RPICK) TOS = *(rp - TOS.n); MIRP + +// 2.1 +PRIM(_X2b) NOS.u += TOS.u; POP; MIRP +PRIM(_X2d) NOS.u -= TOS.u; POP; MIRP +PRIM(_X2a) NOS.u *= TOS.u; POP; MIRP + +// 2.2 +PRIM(LSHIFT) NOS.u <<= TOS.u; POP; MIRP +PRIM(RSHIFT) NOS.u >>= TOS.u; POP; MIRP +PRIM(ASHIFT) NOS.n >>= TOS.u; POP; MIRP +PRIM(AND) NOS.u &= TOS.u; POP; MIRP +PRIM(OR) NOS.u |= TOS.u; POP; MIRP +PRIM(XOR) NOS.u ^= TOS.u; POP; MIRP + +// 3.1 +#define GET_TYPE1(t) { \ + t *restrict a = (t *restrict)(TOS.a); \ + t b; + +#define GET_TYPE2(t) \ + b = *a; + +#define GET_TYPE3(t) \ + TOS.u = b; \ +} + +#define PUT_TYPE1(t) { \ + t *restrict a = TOS.a; \ + t b = NOS.u; \ + POP; \ + POP; + +#define PUT_TYPE2(t) \ + *a = b; \ +} + +#define GET_CELL1 GET_TYPE1(type_u) +#define PUT_CELL1 PUT_TYPE1(type_u) +#define GET_CHAR1 GET_TYPE1(type_c) +#define PUT_CHAR1 PUT_TYPE1(type_c) +#define GET_WORD1 GET_TYPE1(type_w) +#define PUT_WORD1 PUT_TYPE1(type_w) +#define GET_LONG1 GET_TYPE1(type_l) +#define PUT_LONG1 PUT_TYPE1(type_l) +#define GET_XONG1 GET_TYPE1(type_u) +#define PUT_XONG1 PUT_TYPE1(type_u) + +#define GET_CELL2 GET_TYPE2(type_u) +#define PUT_CELL2 PUT_TYPE2(type_u) +#define GET_CHAR2 GET_TYPE2(type_c) +#define PUT_CHAR2 PUT_TYPE2(type_c) +#define GET_WORD2 GET_TYPE2(type_w) +#define PUT_WORD2 PUT_TYPE2(type_w) +#define GET_LONG2 GET_TYPE2(type_l) +#define PUT_LONG2 PUT_TYPE2(type_l) +#define GET_XONG2 GET_TYPE2(type_u) +#define PUT_XONG2 PUT_TYPE2(type_u) + +#define GET_CELL3 GET_TYPE3(type_u) +#define GET_CHAR3 GET_TYPE3(type_c) +#define GET_WORD3 GET_TYPE3(type_w) +#define GET_LONG3 GET_TYPE3(type_l) +#define GET_XONG3 GET_TYPE3(type_u) + +#define GET_CELL GET_CELL1 GET_CELL2 GET_CELL3 +#define PUT_CELL PUT_CELL1 PUT_CELL2 +#define GET_CHAR GET_CHAR1 GET_CHAR2 GET_CHAR3 +#define PUT_CHAR PUT_CHAR1 PUT_CHAR2 +#define GET_WORD GET_WORD1 GET_WORD2 GET_WORD3 +#define PUT_WORD PUT_WORD1 PUT_WORD2 +#define GET_LONG GET_LONG1 GET_LONG2 GET_LONG3 +#define PUT_LONG PUT_LONG1 PUT_LONG2 +#define GET_XONG GET_XONG1 GET_XONG2 GET_XONG3 +#define PUT_XONG PUT_XONG1 PUT_XONG2 + + PRIM(_X40) GET_CELL; MIRP + PRIM(_X21) PUT_CELL; MIRP + PRIM(C_X40) GET_CHAR; MIRP + PRIM(C_X21) PUT_CHAR; MIRP + PRIM(W_X40) GET_WORD; MIRP + PRIM(W_X21) PUT_WORD; MIRP + PRIM(L_X40) GET_LONG; MIRP + PRIM(L_X21) PUT_LONG; MIRP + PRIM(X_X40) GET_XONG; MIRP + PRIM(X_X21) PUT_XONG; MIRP + + +#define UGET_TYPE1(t) { \ + type_c *restrict a = (type_c *restrict)(TOS.a); \ + t b; \ + type_c *restrict c = (type_c *restrict)&b; + +#define UGET_TYPE2(t) \ + *c++ = *a++; \ + *c++ = *a++; + +#define UGET_TYPE3(t) \ + TOS.u = b; \ +} + +#define UPUT_TYPE1(t) { \ + type_c *restrict a = (type_c *restrict)(TOS.a); \ + t b = NOS.u; \ + type_c *restrict c = (type_c *restrict)&b; \ + POP; \ + POP; + +#define UPUT_TYPE2(t) \ + *a++ = *c++; \ + *a++ = *c++; + +#define UPUT_TYPE3(t) } + +#define UGET_WORD1 UGET_TYPE1(type_w) +#define UPUT_WORD1 UPUT_TYPE1(type_w) +#define UGET_WORD2 UGET_TYPE2(type_w) +#define UPUT_WORD2 UPUT_TYPE2(type_w) +#define UGET_WORD3 UGET_TYPE3(type_w) +#define UPUT_WORD3 UPUT_TYPE3(type_w) +#define UGET_LONG1 UGET_TYPE1(type_l) +#define UPUT_LONG1 UPUT_TYPE1(type_l) +#define UGET_LONG2 UGET_TYPE2(type_l) +#define UPUT_LONG2 UPUT_TYPE2(type_l) +#define UGET_LONG3 UGET_TYPE3(type_l) +#define UPUT_LONG3 UPUT_TYPE3(type_l) + +#define UGET_WORD UGET_WORD1 UGET_WORD2 UGET_WORD3 +#define UPUT_WORD UPUT_WORD1 UPUT_WORD2 UPUT_WORD3 +#define UGET_LONG UGET_LONG1 UGET_LONG2 UGET_LONG2 UGET_LONG3 +#define UPUT_LONG UPUT_LONG1 UPUT_LONG2 UPUT_LONG2 UPUT_LONG3 + + PRIM(UNALIGNED_X2d_W_X40) UGET_WORD; MIRP + PRIM(UNALIGNED_X2d_W_X21) UPUT_WORD; MIRP + PRIM(UNALIGNED_X2d_L_X40) UGET_LONG; MIRP + PRIM(UNALIGNED_X2d_L_X21) UPUT_LONG; MIRP + + +// 6 +PRIM(_X3c) NOS.n = -(NOS.n < TOS.n); POP; MIRP +PRIM(U_X3c) NOS.n = -(NOS.u < TOS.u); POP; MIRP +PRIM(0_X3c) TOS.n = -(TOS.n < 0); MIRP +PRIM(_X3d) NOS.n = -(NOS.u == TOS.u); POP; MIRP +PRIM(0_X3d) TOS.n = -(TOS.u == 0); MIRP + + + + + + +// 8.4 +PRIM(DODO) RPUSH; RTOS = NOS; RPUSH; RTOS = TOS; POP; POP; MIRP +code_DO_X3f_DO: + { + cell i = *dp--; + cell n = *dp--; + type_n dis = (++ip)->n; + if (i.n == n.n) + ip = (cell *restrict)((type_c *restrict)ip + dis); + else { + *(rp + 1) = n; + *(rp += 2) = i; + } + NEXT; + } +code_DOLOOP: + { + type_n dis = (++ip)->n; + rp->n++; + if (rp->n == (rp - 1)->n) + rp -= 2; + else + ip = (cell *restrict)((type_c *restrict)ip + dis); + NEXT; + } +code_DO_X2b_LOOP: + { + type_u lo, hi; + type_n inc; + type_n dis = (++ip)->n; + lo = rp->u; + inc = (dp--)->n; + rp->n += inc; + if (inc >= 0) + hi = rp->u; + else { + hi = lo; + lo = rp->u; + } + if ((type_u)((rp - 1)->n - 1 - lo) < hi - lo) + rp -= 2; + else + ip = (cell *restrict)((type_c *restrict)ip + dis); + NEXT; + } +code_DOLEAVE: + { + type_n dis = (++ip)->n; + rp -= 2; + ip = (cell *restrict)((type_c *restrict)ip + dis); + NEXT; + } +code_DO_X3f_LEAVE: + { + type_n dis = (++ip)->n; + if ((dp--)->n) { + rp -= 2; + ip = (cell *restrict)((type_c *restrict)ip + dis); + } + NEXT; + } + + + + + + +// 8.5 +code_EXIT: + { + ip = (rp--)->a; + NEXT; + } + +code_SEMICOLON: + { + ip = (rp--)->a; + NEXT; + } + +code_EXECUTE: // don't need this as prim + { + cfa = (dp--)->a; + NEXT00; + } + + +PRIM(MOVE) + type_u n = TOS.u; POP; + unsigned char *q = TOS.a; POP; + unsigned char *p = TOS.a; POP; + + _FASTMOVE(p, q, n); +MIRP + +code_FILL: + { + unsigned char c = (dp--)->u; + type_n size = ((dp--)->n); + unsigned char *d = (unsigned char *)((dp--)->u); + type_u fill_v=c | c <<8; + + fill_v |= fill_v << 16; + switch (((type_u)d | (type_u)size) & (sizeof(type_u)-1)) { + case 0: { + type_u *up = (type_u *)d; +#if (__LONG_MAX__ > 2147483647L) + fill_v |= fill_v << 32; +#endif + while ((size-=sizeof(type_u)) >= 0) + *up++ = fill_v; + } + case sizeof(type_l): { + type_l *lp = (type_l *)d; + + while ((size-=sizeof(type_l)) >= 0) + *lp++ = (type_l)fill_v; + } + case sizeof(type_w): { + type_w *wp = (type_w *)d; + + while ((size-=sizeof(type_w)) >= 0) + *wp++ = (type_w)fill_v; + } + default: + while (size-- > 0) + *d++ = (unsigned char)c; + } + NEXT; + } + +code_COMP: + { + type_n len = ((dp--)->n); + unsigned char *addr2 = (unsigned char *)((dp--)->u); + unsigned char *addr1 = (unsigned char *)((dp--)->u); + + while (len-- > 0) { + if (*addr1 > *addr2) { + (++dp)->n = 1; + NEXT; + } + else if (*addr1 < *addr2) { + (++dp)->n = -1; + NEXT; + } + addr1 += 1; + addr2 += 1; + } + (++dp)->n = 0; + NEXT; + } + + +PRIM(RMOVE) + type_u size = ((dp--)->u); + type_u *d = (type_u *)((dp--)->u); + type_u *s = (type_u *)((dp--)->u); + _FASTRMOVE(s, d, size); + + MIRP + +PRIM(MRMOVE) + type_u size = TOS.u; POP; + void *d = TOS.a; POP; + void *s = TOS.a; POP; + FAST_MRMOVE(s, d, size); + MIRP + +PRIM(RFILL) + type_u pat = TOS.u; POP; + type_u size = TOS.u; POP; + void *dst = TOS.a; POP; + FAST_RFILL(dst, size, pat); + MIRP + +// String compare, case insensitive: +// : string=ci ( str1 len1 str2 len2 -- equal? ) +PRIM(STRING_X3d_CI) + type_u l2 = TOS.u; POP; + unsigned char *p2 = TOS.a; POP; + type_u l1 = TOS.u; POP; + unsigned char *p1 = TOS.a; + + if (l1 == l2) { + TOS.n = -1; /* Default to TRUE */ + while (l1 > 0) { + if (toupper(*p1) != toupper(*p2)) { + TOS.n = 0; + break; + } + ++p1; ++p2; + --l1; + } + } + else { + TOS.n = 0; + } +MIRP + +// bool dependend pick +// ?PICK ( v1 v2 bool -- v1|v2 ) +PRIM(_X3f_PICK) + type_u b = TOS.u; POP; + if (b) { NOS = TOS; } + POP; +MIRP + +/* zcount ( zstr -- str len ) */ +PRIM(ZCOUNT) + type_u len = strlen(TOS.a); + PUSH; TOS.u = len; +MIRP + +PRIM(CLEAN_X2d_HASH) + memset(hash_table, 0, sizeof(hash_table)); +MIRP + +PRIM(HASH_X2d_TABLE) + PUSH; + TOS.a = hash_table; +MIRP + +/* hash ( str len -- hash ) + * this word is used in find-hash.fs to create + * a hash to accelerate word lookup */ +PRIM(HASH) + type_u len = TOS.u; POP; + unsigned char *str = TOS.a; + type_u tmp = len; + type_u hash = 0; + while(len--) { + hash <<= 1; + hash ^= tolower(*str); + hash ^= tmp; + str++; + } + /* we only want hash values which size is smaller + * than HASHSIZE */ + hash &= HASHSIZE - 1; + /* access the hash table in steps of CELLSIZE */ + hash *= CELLSIZE; + /* return a pointer for this hash in the hash table */ + TOS.a = hash_table + hash; +MIRP diff --git a/src/roms/SLOF/slof/prim.in b/src/roms/SLOF/slof/prim.in new file mode 100644 index 0000000..855f592 --- /dev/null +++ b/src/roms/SLOF/slof/prim.in @@ -0,0 +1,114 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ + +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + +cod(TIB) +cod(POCKETS) +cod(EREGS) +cod(CIREGS) +cod(CISTACK) +// compile buffer for the "structure words in interpret mode" OF extension +cod(COMP-BUFFER) + +cod(PAFLOF-START) +cod(HEAP-START) +cod(HEAP-END) +// flattened device tree start address +cod(FDT-START) +// romfs start address +cod(ROMFS-BASE) +// if the low level firmware is epapr compliant it will put the +// epapr magic into r6 before starting paflof +// epapr-magic is a copy of r6 +cod(EPAPR-MAGIC) +// ePAPR Initially mapped area size +cod(EPAPR-IMA-SIZE) + +cod(BRANCH) _ADDING _O +cod(0BRANCH) _ADDING _O +dfr(BP) +cod(BREAKPOINT) + +cod(LIT) _ADDING _N +cod(DOTICK) + +cod(DUP) +cod(OVER) +cod(PICK) +cod(DROP) +cod(SWAP) + +cod(>R) +cod(R>) +cod(R@) +cod(RPICK) + +cod(DEPTH) +cod(DEPTH!) +cod(RDEPTH) +cod(RDEPTH!) + +cod(+) +cod(-) +cod(*) +cod(LSHIFT) +cod(RSHIFT) +cod(ASHIFT) +cod(AND) +cod(OR) +cod(XOR) + +cod(@) +cod(!) +cod(C@) +cod(C!) +cod(W@) +cod(W!) +cod(L@) +cod(L!) +cod(X@) +cod(X!) + +cod(UNALIGNED-W@) +cod(UNALIGNED-W!) +cod(UNALIGNED-L@) +cod(UNALIGNED-L!) + +cod(<) +cod(U<) +cod(0<) +cod(=) +cod(0=) + +cod(DODO) +cod(DO?DO) _ADDING _O +cod(DOLOOP) _ADDING _O +cod(DO+LOOP) _ADDING _O +cod(DOLEAVE) _ADDING _O +cod(DO?LEAVE) _ADDING _O + +cod(EXIT) +cod(SEMICOLON) +cod(EXECUTE) + +cod(MOVE) +cod(RMOVE) +cod(MRMOVE) +cod(RFILL) +cod(ZCOUNT) +con(HASH-SIZE HASHSIZE) +cod(HASH) +cod(CLEAN-HASH) +cod(HASH-TABLE) diff --git a/src/roms/SLOF/slof/ref.pl b/src/roms/SLOF/slof/ref.pl new file mode 100644 index 0000000..b21f139 --- /dev/null +++ b/src/roms/SLOF/slof/ref.pl @@ -0,0 +1,148 @@ +# ***************************************************************************** +# * Copyright (c) 2004, 2008 IBM Corporation +# * All rights reserved. +# * This program and the accompanying materials +# * are made available under the terms of the BSD License +# * which accompanies this distribution, and is available at +# * http://www.opensource.org/licenses/bsd-license.php +# * +# * Contributors: +# * IBM Corporation - initial implementation +# ****************************************************************************/ +#!/usr/bin/perl + +# +# Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +# + + +use Getopt::Std; +use Data::Dumper; + +$CELLSIZE = length(sprintf "%x", ~0) / 2; +$CELLSIZE = 8; +$DEBUG = 0; + +sub usage +{ + printf STDERR "Usage: ref.pl [ -s 32|64 ] [ -d ] \n"; + printf STDERR " ref.pl -h\n"; + exit 0; +} + +sub string +{ + my ($s, $extra) = @_; + + $DEBUG and printf STDERR "\nstring:[%s][%02x]\n", $s, ord $extra; + $s = sprintf "%s%c%s", $extra, length($s), $s; + @s = ($s =~ /(.{1,$CELLSIZE})/gs); + do { s/([\x00-\x1f\x22\x5c\x7f-\xff])/sprintf "\\%03o", ord $1/egs } for @s; + my @reut = ("{ .c = \"" . (join "\" }, { .c = \"", @s) . "\" },", scalar @s); + # $DEBUG and print STDERR Dumper \@reut; + return @reut; +} + +sub forth_to_c_name +{ + ($_, my $numeric) = @_; + s/([^a-zA-Z0-9])/sprintf("_X%02x_", ord($1))/ge; + s/__/_/g; +# s/^_//; + s/_$//; + s/^(\d)/_$1/ if $numeric; + return $_; +} + +sub special_forth_to_c_name +{ + ($_, my $numeric) = @_; + + $DEBUG and print STDERR "\tasked for $_ [[numeric is $numeric]]\n"; + my ($name, $arg) = (/^([^(]+)(.*)$/); + # $DEBUG and print STDERR "\tname is $name -- arg is $arg\n"; + if ($special{$name} == 1) { + $_ = forth_to_c_name($name, $numeric) . $arg; + } elsif ($special{$name} != 2) { + $_ = forth_to_c_name($_, $numeric); + } + # $DEBUG and print STDERR "\tmaking it $_\n"; + return $_; +} + +getopts('dhs:') or die "Invalid option!\n"; + +$opt_h and usage(); +$opt_d and $DEBUG=1; +$opt_s and $opt_s != 32 and $opt_s != 64 and die("Only -s32 or -s64 allowed"); + +$opt_s and $opt_s == 32 and $CELLSIZE=4; + +$DEBUG and printf STDERR "Cell size set to $CELLSIZE;\n"; + +$link = "0"; +%special = ( _N => 2, _O => 2, _C => 2, _A => 2 ); + +$DEBUG and print STDERR "Compiling:"; +while ($line = <>) { + if ($line =~ /^([a-z]{3})\(([^ ]+)./) { + $typ = $1; + $name = $2; + + $DEBUG and print STDERR "\n\t\t$name###\n"; + + $name =~ s/\)$// if $line =~ /\)\s+_ADDING.*$/; + # $DEBUG and print STDERR " $name"; + $cname = forth_to_c_name($name, 1); + $par = ''; + $add = ''; + $extra = "\0"; + if ($typ eq "imm") { + $typ = "col"; + $extra = "\1"; + } +# if ($typ eq "com") { +# $typ = "col"; +# $extra = "\3"; +# } + ($str, $strcells) = (string $name, $extra); + if ($line =~ /^str\([^"]*"([^"]*)"/) { + # $DEBUG and print STDERR "[[[$1]]]\n"; + ($s) = (string $1); + $line =~ s/"[^"]*"/$s/; + } + if ($line =~ /_ADDING +(.*)$/) { + $special{$name} = 1; + @typ = (split /\s+/, $1); + $count = 0; + $par = "(" . (join ", ", map { $count++; "_x$count" } @typ) . ")"; + $count = 0; + $add = join " ", map { $count++; "$_(_x$count)" } @typ; + $line =~ s/\s+_ADDING.*$//; + } + # $DEBUG and print STDERR $line; + ($body) = ($line =~ /^...\((.*)\)$/); + @body = split " ", $body; + # $DEBUG and print STDERR "\n"; + # $DEBUG and print STDERR "BODY WAS: ", (join " ", @body), "\n"; + if ($typ ne "str" and $typ ne "con") { + @body = map { special_forth_to_c_name($_, $typ eq "col") } @body; + } else { + $body[0] = special_forth_to_c_name($body[0]); + } + # $DEBUG and print STDERR "BODY IS: ", (join " ", @body), "\n"; + $body = join " ", @body; + $body =~ s/ /, /; + # $DEBUG and print STDERR "===> $body\n"; + + print "header($cname, { .a = $link }, $str) "; + $link = "xt_$cname"; + print "$typ($body)\n"; + print "#define $cname$par ref($cname, $strcells+1) $add\n"; + (my $xxcname) = ($cname =~ /^_?(.*)/); + $add and print "#define DO$xxcname ref($cname, $strcells+1)\n"; + } else { + print $line; + } +} +$DEBUG and print STDERR "\n"; diff --git a/src/roms/SLOF/slof/types.h b/src/roms/SLOF/slof/types.h new file mode 100644 index 0000000..e347cc3 --- /dev/null +++ b/src/roms/SLOF/slof/types.h @@ -0,0 +1,49 @@ +/****************************************************************************** + * Copyright (c) 2004, 2008 IBM Corporation + * All rights reserved. + * This program and the accompanying materials + * are made available under the terms of the BSD License + * which accompanies this distribution, and is available at + * http://www.opensource.org/licenses/bsd-license.php + * + * Contributors: + * IBM Corporation - initial implementation + *****************************************************************************/ +// +// Copyright 2002,2003,2004 Segher Boessenkool <segher@kernel.crashing.org> +// + + +#ifndef _TYPES_H +#define _TYPES_H + +#if 0 +#include <stdint.h> + +typedef uint8_t type_c; // 1 byte +typedef uint16_t type_w; // 2 bytes +typedef uint32_t type_l; // 4 bytes +typedef intptr_t type_n; // cell size +typedef uintptr_t type_u; // cell size +#else +typedef unsigned char type_c; // 1 byte +typedef unsigned short type_w; // 2 bytes +typedef unsigned int type_l; // 4 bytes +typedef long type_n; // cell size +typedef unsigned long type_u; // cell size +#endif + +//#define CELLSIZE (sizeof(type_u) / sizeof(type_c)) +#define CELLSIZE sizeof(type_u) + +typedef union cell { + type_n n; + type_u u; + void *a; + type_c c[CELLSIZE]; + type_w w[CELLSIZE/2]; + type_l l[CELLSIZE/4]; +} cell; + + +#endif /* _TYPES_H */ |
