diff options
| author | Benjamin Herrenschmidt <benh@kernel.crashing.org> | 2010-12-01 09:51:44 +1100 |
|---|---|---|
| committer | Benjamin Herrenschmidt <benh@kernel.crashing.org> | 2010-12-01 09:51:44 +1100 |
| commit | aaad509cdca2ed5f2c92a26f5279ec0e89c4fd5f (patch) | |
| tree | dfffc0d8f3d21f6736b7f09219c95e2370052d8a /slof | |
| download | SLOF-aaad509cdca2ed5f2c92a26f5279ec0e89c4fd5f.zip SLOF-aaad509cdca2ed5f2c92a26f5279ec0e89c4fd5f.tar.gz SLOF-aaad509cdca2ed5f2c92a26f5279ec0e89c4fd5f.tar.bz2 | |
Initial import of slof-JX-1.7.0-4
Signed-off-by: Benjamin Herrenschmidt <benh@kernel.crashing.org>
Diffstat (limited to 'slof')
108 files changed, 21799 insertions, 0 deletions
diff --git a/slof/Makefile.inc b/slof/Makefile.inc new file mode 100644 index 0000000..a8b3a37 --- /dev/null +++ b/slof/Makefile.inc @@ -0,0 +1,161 @@ +# ***************************************************************************** +# * 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) +ASFLAGS = -Wa,-mpower4 -Wa,-mregnames $(FLAG) $(CPUARCHDEF) + +LDFLAGS += -static -nostdlib + +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 + +# 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 + rm -f $@ + cpp $(FPPFLAGS) $(FPPINCLUDES) $< > $@.tmp + sed -e 's/^[ \t]*//' < $@.tmp \ + | sed -e '/^\\[ \t]/d' \ + | sed -e '/^([ \t][^)]*[ \t])[ \t]*$$/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 \ + romfs.o OF.o nvramlog.o $(LLFWBRDDIR)/board_io.o \ + $(LLFWBRDDIR)/io_generic_lib.o $(SLOF_LIBS) + $(CC) -T$(SLOFCMNDIR)/OF.lds $(SLOFCMNDIR)/ofw.o paflof.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) -s $@ + +paflof.o: + $(CC) $(CPPFLAGS) $(CFLAGS) -c -o $@ $(SLOFCMNDIR)/paflof.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 \ + pushd . >/dev/null ; cd `dirname $$i` ; \ + DIRNAME=`pwd` ; popd >/dev/null; \ + 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/slof/OF.lds b/slof/OF.lds new file mode 100644 index 0000000..5f8b2b1 --- /dev/null +++ b/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/slof/default-font.c b/slof/default-font.c new file mode 100644 index 0000000..328f1b4 --- /dev/null +++ b/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/slof/engine.in b/slof/engine.in new file mode 100644 index 0000000..2cc9d26 --- /dev/null +++ b/slof/engine.in @@ -0,0 +1,540 @@ +/****************************************************************************** + * 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 SWAP 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) + +// 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(' PARSE-WORD $FIND 0= DOTICK UNDEFINED-STR DOABORT" DROP) + +// 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 $FIND 0= DOTICK UNDEFINED-STR DOABORT" IMMEDIATE? 0= 0BRANCH(6) DOTICK DOTICK COMPILE, COMPILE, DOTICK COMPILE, COMPILE,) +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/slof/entry.S b/slof/entry.S new file mode 100644 index 0000000..ce9dd83 --- /dev/null +++ b/slof/entry.S @@ -0,0 +1,187 @@ +/****************************************************************************** + * 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 0x1000 + + # + # 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 + bctrl + bl swap_ci_regs + mtlr 4 + li 3, -1 # client app return + blr + + .lcomm the_system_stack, STACKSIZE, 16 diff --git a/slof/fs/accept.fs b/slof/fs/accept.fs new file mode 100644 index 0000000..7e8e271 --- /dev/null +++ b/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/slof/fs/alloc-mem.fs b/slof/fs/alloc-mem.fs new file mode 100644 index 0000000..59381a7 --- /dev/null +++ b/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/slof/fs/available.fs b/slof/fs/available.fs new file mode 100644 index 0000000..5eb8fa9 --- /dev/null +++ b/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/slof/fs/banner.fs b/slof/fs/banner.fs new file mode 100644 index 0000000..efdba0c --- /dev/null +++ b/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/slof/fs/base.fs b/slof/fs/base.fs new file mode 100644 index 0000000..33fe7bc --- /dev/null +++ b/slof/fs/base.fs @@ -0,0 +1,558 @@ +\ ***************************************************************************** +\ * 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+ +; + +\ Standard compliant $find +: $find ( str len -- xt true | str len false ) + 2dup $find + IF + drop nip nip TRUE + ELSE + FALSE + THEN +; + +CREATE $catpad 100 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> 2@ ; +: $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 ; + +: #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 occurence 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 ; + +: // 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 +: 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 upto 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 + +\ 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 ( -- ) ." disable-watchdog not available" cr ; +: nop-reset-watchdog ( -- ) ." reset-watchdog not available" cr ; +: nop-set-watchdog ( +n -- ) drop ." set-watchdog not available" cr ; +: 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 +10000000 value load-base +2000000 value flash-load-base + +\ provide first level debug support +#include "debug.fs" +\ provide 7.5.3.1 Dictionary search +#include "dictionary.fs" +\ block data access for IO devices - ought to be implemented in engine +#include "rmove.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/slof/fs/boot.fs b/slof/fs/boot.fs new file mode 100644 index 0000000..3980563 --- /dev/null +++ b/slof/fs/boot.fs @@ -0,0 +1,243 @@ +\ ***************************************************************************** +\ * 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 + 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 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 ( -- ) + state-valid @ IF + 0 ciregs >r3 ! 0 ciregs >r4 ! + go-args 2@ go-entry start-elf64 client-data + claim-list elf-release 0 to claim-list + 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 + + dup ['] elf-check-file CATCH IF + ( -64 THROW ) \ Not now, let the 'go' (i.e. no-go) whine about it + drop 0 + THEN + CASE + 1 OF true swap ['] load-elf32-claim CATCH IF + 2drop drop -66 THROW + THEN + ['] go-32 ENDOF ( arg len true claim-list entry go ) + 2 OF true swap ['] load-elf64-claim CATCH IF + 2drop drop -66 THROW + THEN + ['] go-64 ENDOF ( arg len true claim-list entry go ) + dup OF drop ['] no-go to go + 2drop 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 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 ) + my-args nip 0= IF + 2dup 1- + c@ [char] : <> IF \ Add : to device path if missing + 1+ strdup 2dup 1- + [char] : swap c! + THEN + THEN + encode-string s" bootpath" set-chosen + $bootargs encode-string s" bootargs" set-chosen + 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) ( -- ) + ['] 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 + (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 >r FLASH-LOAD-BASE to load-base + s" load net:" strdup 2swap $cat strdup evaluate + r> to load-base + load-size +; + +: neteval ( -- ) FLASH-LOAD-BASE netload evaluate ; + diff --git a/slof/fs/bootmsg.fs b/slof/fs/bootmsg.fs new file mode 100644 index 0000000..524d469 --- /dev/null +++ b/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/slof/fs/claim.fs b/slof/fs/claim.fs new file mode 100644 index 0000000..f12e37c --- /dev/null +++ b/slof/fs/claim.fs @@ -0,0 +1,403 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +\ \\\\\\\\\\\\\\ Constants +500 CONSTANT AVAILABLE-SIZE +10000000 CONSTANT MIN-RAM-SIZE \ assumed minimal memory size +4000 CONSTANT MIN-RAM-RESERVE \ prevent from using first pages + +\ \\\\\\\\\\\\\\ 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 > ; + +: (?available-segment-#) ( start1 end1 start2 end2 -- true/false ) + 4dup ( s1 e1 s2 e2 s1 e1 s2 e2 ) + 3 pick 3 pick between >r + -rot between r> and IF 4drop TRUE EXIT THEN + 2dup 5 roll -rot ( e1 s2 e2 s1 s2 e2 ) + between >r between r> xor +; + +: (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 + + dup >r available@ 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 +E000000 2000000 0 ' claim CATCH IF ." claim failed!" cr 2drop THEN drop + diff --git a/slof/fs/client.fs b/slof/fs/client.fs new file mode 100644 index 0000000..642d04f --- /dev/null +++ b/slof/fs/client.fs @@ -0,0 +1,208 @@ +\ ***************************************************************************** +\ * 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. + +\ 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 + ALSO client-voc $find PREVIOUS IF nip FALSE ELSE nip nip TRUE THEN + ; + +: finddevice ( zstr -- phandle ) + zcount find-node dup 0= IF drop -1 THEN ; + +: getprop ( phandle zstr buf len -- len' ) + >r >r zcount rot get-property + 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' ) + over >r move r> zcount nip ; + +: 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 open-dev ; +: close ( ihandle -- ) close-dev ; + +\ 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 ) + dup IF rot drop + ['] claim CATCH IF 2drop -1 THEN + ELSE + ['] claim CATCH IF 3drop -1 THEN + THEN +; + +: release ( addr len -- ) 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 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 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 ( -- ) + \ The main quiesce call is defined in quiesce.fs + quiesce +; + +\ +\ User Interface, defined in 6.3.2.6 +\ +: interpret ( ... zstr -- result ... ) + zcount ['] evaluate CATCH ; + +\ Allow the client to register a callback +: set-callback ( newfunc -- oldfunc ) + client-callback @ swap client-callback ! ; + +PREVIOUS DEFINITIONS diff --git a/slof/fs/debug.fs b/slof/fs/debug.fs new file mode 100644 index 0000000..bfdc9fc --- /dev/null +++ b/slof/fs/debug.fs @@ -0,0 +1,437 @@ +\ ***************************************************************************** +\ * 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 constant <debug-dummy> + +12 34 2constant (2constant) ' (2constant) cell+ @ +\ fake device node +here 0 +dup , dup , dup , dup , dup , +over 7 cells + , +dup , dup , dup , dup , dup , +dup , drop +current-node ! \ FAKE! +12 instance value (instancevalue) ' (instancevalue) cell+ @ +instance variable (instancevariable) ' (instancevariable) cell+ @ +instance defer (instancedefer) ' (instancedefer) cell+ @ +0 current-node ! + +forget <debug-dummy> + +constant <instancedefer> +constant <instancevariable> +constant <instancevalue> +constant <2constant> + + +\ 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 ) + 2 pick (u.) dup -rot cr type ( indent limit xt str len xt-len ) + " :" type 1+ ( indent limit xt str len prefix-len ) + 5 pick dup spaces + ( indent limit xt str len prefix-len ) + over + see-my-type-column ! ( indent limit xt str 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 + <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 + <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 overwriten 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 overwriten 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/slof/fs/devices/pci-class_02.fs b/slof/fs/devices/pci-class_02.fs new file mode 100644 index 0000000..ff78496 --- /dev/null +++ b/slof/fs/devices/pci-class_02.fs @@ -0,0 +1,35 @@ +\ ***************************************************************************** +\ * 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 ( -- ) + s" close" obp-tftp-package @ $call-method + 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/slof/fs/devices/pci-class_0c.fs b/slof/fs/devices/pci-class_0c.fs new file mode 100644 index 0000000..53e1e19 --- /dev/null +++ b/slof/fs/devices/pci-class_0c.fs @@ -0,0 +1,39 @@ +\ ***************************************************************************** +\ * 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" serial bus [ " type my-space pci-class-name type s" ]" type cr + +my-space pci-device-generic-setup + + +\ Handle USB OHCI controllers: +: handle-usb-ohci-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 + 10 config-l@ \ get base address on stack for usb-ohci.fs + \ TODO: Use translate-address here + s" usb-ohci.fs" included +; + +\ 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 handle-usb-ohci-class ENDOF \ USB OHCI controller + ENDCASE +; + +handle-sbc-subclass + diff --git a/slof/fs/devices/pci-device_10de_0141.fs b/slof/fs/devices/pci-device_10de_0141.fs new file mode 100644 index 0000000..507c383 --- /dev/null +++ b/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 + +enable-io-access +enable-mem-access + +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 availabe, 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/slof/fs/dictionary.fs b/slof/fs/dictionary.fs new file mode 100644 index 0000000..5d1dae7 --- /dev/null +++ b/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 occurences + 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/slof/fs/display.fs b/slof/fs/display.fs new file mode 100644 index 0000000..5bb8797 --- /dev/null +++ b/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/slof/fs/dump.fs b/slof/fs/dump.fs new file mode 100644 index 0000000..90d60c4 --- /dev/null +++ b/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/slof/fs/elf.fs b/slof/fs/elf.fs new file mode 100644 index 0000000..8f1c7b7 --- /dev/null +++ b/slof/fs/elf.fs @@ -0,0 +1,305 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +\ ELF 32 bit header + +STRUCT + /l field ehdr>e_ident + /c field ehdr>e_class + /c field ehdr>e_data + /c field ehdr>e_version + /c field ehdr>e_pad + /l field ehdr>e_ident_2 + /l field ehdr>e_ident_3 + /w field ehdr>e_type + /w field ehdr>e_machine + /l field ehdr>e_version + /l field ehdr>e_entry + /l field ehdr>e_phoff + /l field ehdr>e_shoff + /l field ehdr>e_flags + /w field ehdr>e_ehsize + /w field ehdr>e_phentsize + /w field ehdr>e_phnum + /w field ehdr>e_shentsize + /w field ehdr>e_shnum + /w field ehdr>e_shstrndx +END-STRUCT + + +\ ELF 32 bit program header + +STRUCT + /l field phdr>p_type + /l field phdr>p_offset + /l field phdr>p_vaddr + /l field phdr>p_paddr + /l field phdr>p_filesz + /l field phdr>p_memsz + /l field phdr>p_flags + /l field phdr>p_align +END-STRUCT + +\ Provide word to load image to an offset of vaddr +0 value elf-segment-offset + +: xlate-vaddr32 ( programm-header-addr -- addr ) + phdr>p_vaddr l@ elf-segment-offset + +; + + +\ ELF 64 bit header + +STRUCT + /l field ehdr64>e_ident + /c field ehdr64>e_class + /c field ehdr64>e_data + /c field ehdr64>e_version + /c field ehdr64>e_pad + /l field ehdr64>e_ident_2 + /l field ehdr64>e_ident_3 + /w field ehdr64>e_type + /w field ehdr64>e_machine + /l field ehdr64>e_version + cell field ehdr64>e_entry + cell field ehdr64>e_phoff + cell field ehdr64>e_shoff + /l field ehdr64>e_flags + /w field ehdr64>e_ehsize + /w field ehdr64>e_phentsize + /w field ehdr64>e_phnum + /w field ehdr64>e_shentsize + /w field ehdr64>e_shnum + /w field ehdr64>e_shstrndx +END-STRUCT + + +\ ELF 64 bit program header + +STRUCT + /l field phdr64>p_type + /l field phdr64>p_flags + cell field phdr64>p_offset + cell field phdr64>p_vaddr + cell field phdr64>p_paddr + cell field phdr64>p_filesz + cell field phdr64>p_memsz + cell field phdr64>p_align +END-STRUCT + + +\ Claim memory for segment +\ Abort, if no memory available + +false value elf-claim? +0 value last-claim + +: claim-segment ( file-addr program-header-addr -- ) + elf-claim? IF + >r + here last-claim , to last-claim \ Setup ptr to last claim + \ Put addr and size ain the data space + r@ phdr>p_vaddr l@ dup , r> phdr>p_memsz l@ dup , ( file-addr addr size ) + 0 ['] claim CATCH IF ABORT" Memory for ELF file already in use " THEN + THEN + 2drop +; + +: claim-segment64 ( file-addr program-header-addr -- ) + elf-claim? IF + >r + here last-claim , to last-claim \ Setup ptr to last claim + \ Put addr and size ain the data space + r@ phdr64>p_vaddr @ dup , r> phdr64>p_memsz @ dup , ( file-addr addr size ) + 0 ['] claim CATCH IF ABORT" Memory for ELF file already in use " THEN + THEN + 2drop +; + +: load-segment ( file-addr program-header-addr -- ) + >r + ( file-addr R: program-header-addr ) + \ Copy into storage + r@ phdr>p_offset l@ + r@ xlate-vaddr32 r@ phdr>p_filesz l@ move + + ( R: programm-header-addr ) + \ Clear BSS + r@ xlate-vaddr32 r@ phdr>p_filesz l@ + + r@ phdr>p_memsz l@ r@ phdr>p_filesz l@ - erase + + ( R: programm-header-addr ) + \ Flush cache + r@ xlate-vaddr32 r> phdr>p_memsz l@ dup 0= IF 2drop ELSE flushcache THEN +; + +: load-segments ( file-addr -- ) + ( file-addr ) + dup dup ehdr>e_phoff l@ + \ Calculate program header address + + ( file-addr program-header-addr ) + over ehdr>e_phnum w@ 0 ?DO \ loop e_phnum times + + ( file-addr program-header-addr ) + dup phdr>p_type l@ 1 = IF \ PT_LOAD ? + + ( file-addr program-header-addr ) + 2dup claim-segment \ claim segment + + ( file-addr program-header-addr ) + 2dup load-segment THEN \ copy segment + + ( file-addr program-header-addr ) + over ehdr>e_phentsize w@ + LOOP \ step to next header + + ( file-addr program-header-addr ) + over ehdr>e_entry l@ + + ( file-addr program-header-addr ) + nip nip \ cleanup +; + +: load-segment64 ( file-addr program-header-addr -- ) + >r + ( file-addr R: program-header-addr ) + \ Copy into storage + r@ phdr64>p_offset @ + r@ phdr64>p_vaddr @ r@ phdr64>p_filesz @ move + + ( R: programm-header-addr ) + \ Clear BSS + r@ phdr64>p_vaddr @ r@ phdr64>p_filesz @ + + r@ phdr64>p_memsz @ r@ phdr64>p_filesz @ - erase + + ( R: programm-header-addr ) + \ Flush cache + r@ phdr64>p_vaddr @ r> phdr64>p_memsz @ dup 0= IF 2drop ELSE flushcache THEN +; + +: load-segments64 ( file-addr -- entry ) + ( file-addr ) + dup dup ehdr64>e_phoff @ + \ Calculate program header address + + ( file-addr program-header-addr ) + over ehdr64>e_phnum w@ 0 ?DO \ loop e_phnum times + + ( file-addr program-header-addr ) + dup phdr64>p_type l@ 1 = IF \ PT_LOAD ? + + ( file-addr program-header-addr ) + 2dup claim-segment64 \ claim segment + + ( file-addr program-header-addr ) + 2dup load-segment64 THEN \ copy segment + + ( file-addr program-header-addr ) + over ehdr64>e_phentsize w@ + LOOP \ step to next header + + ( file-addr program-header-addr ) + over ehdr64>e_entry @ + + ( file-addr program-header-addr entry ) + nip nip \ cleanup +; + +\ Return type of ELF image, abort if not valid +\ 1: 32 Bit PPC image +\ 2: 64 Bit PPC image +\ 5: 32 Bit SPU image + +: elf-check-file ( file-addr -- image-type ) + ( file-addr ) + dup ehdr>e_ident l@-be 7f454c46 <> IF + ABORT" Not an ELF executable" + THEN + + ( file-addr ) + dup ehdr>e_data c@ + ?bigendian IF + 2 <> ABORT" Not a Big Endian ELF file" + ELSE + 2 = ABORT" Not a Little Endian ELF file" + THEN + + ( file-addr ) + dup ehdr>e_type w@ 2 <> ABORT" Not an ELF executable" + + ( file-addr ) + dup ehdr>e_machine w@ + CASE + 14 OF ehdr>e_class c@ ENDOF \ PPC 32 bit executable + 15 OF ehdr>e_class c@ ENDOF \ PPC 64 bit executable + 17 OF ehdr>e_class c@ 4 or ENDOF \ SPU 32 bit executable + dup OF drop ABORT" Not a PPC / SPU ELF executable" ENDOF + ENDCASE +; + +: load-elf32 ( file-addr -- entry ) + + ( file-addr) + load-segments +; + +: load-elf32-claim ( file-addr -- claim-list entry ) + true to elf-claim? + 0 to last-claim + ['] load-elf32 CATCH IF false to elf-claim? ABORT THEN + last-claim swap + false to elf-claim? +; + + +: load-elf64 ( file-addr -- entry ) + + ( file-addr) + load-segments64 +; + +: load-elf64-claim ( file-addr -- claim-list entry ) + true to elf-claim? + 0 to last-claim + ['] load-elf64 CATCH IF false to elf-claim? ABORT THEN + last-claim swap + false to elf-claim? +; + +: load-elf-file ( file-addr -- entry 32-bit ) + + ( file-addr ) + dup elf-check-file + + ( file-addr 1|2|x ) + + CASE + 1 OF 0 to elf-segment-offset load-elf32 true ENDOF + 2 OF 0 to elf-segment-offset load-elf64 false ENDOF + 5 OF load-elf32 true ENDOF + dup OF true ABORT" load-elf-file: Not valid image" ENDOF + ENDCASE +; + +\ Method to load SPU image + +: elf-spu-load ( ls-start-addr file-addr -- entry ) + swap to elf-segment-offset + load-elf-file drop +; + +\ 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/slof/fs/envvar.fs b/slof/fs/envvar.fs new file mode 100644 index 0000000..8a2932d --- /dev/null +++ b/slof/fs/envvar.fs @@ -0,0 +1,420 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ 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, string, DOES> char+ count ; +: 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 +; + +: isdigit ( char -- true | false ) + 30 39 between +; + +: test-int ( param len -- true | false ) + drop c@ isdigit if true else false 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 +; + +: findtype ( param len name len -- param len name len type ) + 2dup findenv dup 0= \ try to find type of envvar + IF \ no type found + drop 2swap + 2dup test-flag if 4 -rot else + 2dup test-secmode if 5 -rot else + 2dup test-int if 1 -rot else + 2dup test-string IF 3 ELSE 2 THEN \ 3 = string, 2 = default to bytes + -rot then then then + rot + >r 2swap r> + \ XXX: create env + else \ take type from default value + nip nip + THEN +; + +\ set an envvar +: $setenv ( param len name len -- ) + 4dup set-option + findtype dup 0= + IF + true ABORT" not a configuration variable" + ELSE + -rot $CREATE CASE + 1 OF evaluate env-int ENDOF \ XXX: wants decimal and 0x... + \ Since we don't have 0x for hexnumbers, we need to find out the type ... + 2 OF + 2dup ( param len param len ) + depth >r ( param len param len R: depth-before ) + ['] evaluate CATCH IF \ Catch 'unknown Forth words'... + ( param len param' len' R: depth-before ) + 2drop r> drop + env-string \ and encode 'unknown word' as string + ELSE + ( param len [...evaluated results...] R: depth-before ) + \ If EVALUATE placed two items on the stack, use env-bytes, + \ for one item use env-int: + depth r> = IF env-bytes ELSE env-int THEN + 2drop + THEN + ENDOF + 3 OF env-string ENDOF + 4 OF evaluate env-flag ENDOF + 5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full + ENDCASE + THEN +; + +\ print an envvar +: (printenv) ( adr type -- ) + CASE + 1 OF aligned @ . ENDOF + 2 OF aligned dup cell+ swap @ dup IF dump ELSE 2drop THEN ENDOF + 3 OF count 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 + dup 0 > IF spaces ELSE + drop space THEN +; + +: .print-one-env + 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 +; + +\ Enviroment variables might be board specific + +#include <envvar_defaults.fs> + +VARIABLE nvoff \ offset in envvar partition + +: (nvupdate-one) ( adr type -- "value" ) + CASE + 1 OF aligned @ (.) ENDOF + 2 OF drop s" 0 0" ENDOF + 3 OF count 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 + 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/slof/fs/envvar_defaults.fs b/slof/fs/envvar_defaults.fs new file mode 100644 index 0000000..21a26e6 --- /dev/null +++ b/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? +true default-flag use-axon-ddr? +#ifdef BIOSEMU +true default-flag use-biosemu? +0 default-int biosemu-debug +#endif diff --git a/slof/fs/exception.fs b/slof/fs/exception.fs new file mode 100644 index 0000000..91e39be --- /dev/null +++ b/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 ." Intruction 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 thru 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/slof/fs/fbuffer.fs b/slof/fs/fbuffer.fs new file mode 100644 index 0000000..d19c330 --- /dev/null +++ b/slof/fs/fbuffer.fs @@ -0,0 +1,178 @@ +\ ***************************************************************************** +\ * 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 window-top +0 VALUE window-left + +0 VALUE .sc +: screen-#rows .sc IF 18 ELSE true to .sc s" screen-#rows" eval false to .sc THEN ; +: screen-#columns .sc IF 50 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-screen? ; +: fb8-foreground inverse? invert ; + +: fb8-lines2bytes ( #lines -- #bytes ) char-height * screen-width * ; +: fb8-columns2bytes ( #columns -- #bytes ) char-width * ; +: fb8-line2addr ( line# -- addr ) + char-height * window-top + screen-width * + frame-buffer-adr + window-left + +; + +: fb8-erase-block ( addr len ) fb8-background rfill ; + + +0 VALUE .ab +CREATE bitmap-buffer 400 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 1+ 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 0 ?DO + char-width 0 ?DO dup dup rb@ -1 xor swap rb! 1+ LOOP + screen-width + char-width - + 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 mrmove + screen-width + >r char-width + 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-width tuck + -rot + swap rot + LOOP + 3drop r> + THEN + char-height 0 ?DO dup 2 pick fb8-erase-block screen-width + 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-width tuck + -rot + swap rot + LOOP + 3drop r> over - + THEN + char-height 0 ?DO dup 2 pick fb8-erase-block screen-width + LOOP 2drop +; + +: fb8-reset-screen ( -- ) ( Left as no-op by design ) ; + +: fb8-erase-screen ( -- ) + frame-buffer-adr screen-height screen-width * fb8-erase-block +; + +: fb8-invert-screen ( -- ) + frame-buffer-adr screen-height screen-width * 2dup /x / 0 ?DO + dup rx@ -1 xor over rx! xa1+ + LOOP 3drop +; + +: fb8-blink-screen ( -- ) fb8-invert-screen fb8-invert-screen ; + +: fb8-install ( width height #columns #lines -- ) + screen-#rows min to #lines + screen-#columns min to #columns + dup to screen-height char-height #lines * - 2/ to window-top + dup to 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 +; + +\ \\\\\\\\\\\\ 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/slof/fs/fcode/1275.fs b/slof/fs/fcode/1275.fs new file mode 100644 index 0000000..ace0933 --- /dev/null +++ b/slof/fs/fcode/1275.fs @@ -0,0 +1,353 @@ +\ ***************************************************************************** +\ * 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 function-type ' function-type @ constant <value> + variable function-type ' function-type @ constant <variable> +0 constant function-type ' function-type @ constant <constant> +: function-type ; ' function-type @ constant <colon> +create function-type ' function-type @ constant <create> +defer function-type ' function-type @ constant <defer> + +\ variable tmp-buf-current +\ variable orig-here +\ create tmp-buf 10000 allot + +( ---------------------------------------------------- ) + +: 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 FFFF swap - negate 2- THEN + ; + +: ?negative + 8000 and + ; + +: dest-on-top + 0 >r BEGIN dup @ 0= WHILE >r REPEAT + BEGIN r> dup WHILE swap REPEAT + drop + ; + +: ?branch + true = + ; + +: read-fcode-offset \ ELSE needs to be fixed! + ?offset16 IF next-ip read-fcode-num16 ELSE THEN + ; + +: b?branch ( flag -- ) + ?compile-mode IF + read-fcode-offset ?negative IF dest-on-top postpone until + ELSE postpone if + THEN + ELSE + ?branch IF 2 jump-n-ip + ELSE read-fcode-offset + ?jump-direction 2- 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 2- jump-n-ip + THEN + ; immediate + +: b(<mark) ( -- ) + ?compile-mode IF postpone begin THEN + ; immediate + +: b(>resolve) ( -- ) + ?compile-mode IF postpone then THEN + ; immediate + +: ffwto; ( -- ) + BEGIN fcode@ dup c2 <> WHILE +." ffwto: skipping " dup . ." @ " get-ip . cr + CASE 10 OF ( lit ) read-fcode-num32 drop ENDOF + 11 OF ( ' ) read-fcode# drop ENDOF + 12 OF ( " ) read-fcode-string 2drop ENDOF + 13 OF ( bbranch ) read-fcode-offset drop ENDOF + 14 OF ( b?branch ) read-fcode-offset drop ENDOF + 15 OF ( loop ) read-fcode-offset drop ENDOF + 16 OF ( +loop ) read-fcode-offset drop ENDOF + 17 OF ( do ) read-fcode-offset drop ENDOF + 18 OF ( ?do ) read-fcode-offset drop ENDOF + 1C OF ( of ) read-fcode-offset drop ENDOF + C6 OF ( endof ) read-fcode-offset drop ENDOF + C3 OF ( to ) read-fcode# drop ENDOF + dup OF next-ip ENDOF + ENDCASE + REPEAT next-ip +; + +: rpush ( rparm -- ) \ push the rparm to be on top of return stack after exit + r> swap >r >r +; + +: rpop ( -- rparm ) \ pop the rparm that was on top of return stack before this + r> r> swap >r +; + +: b1(;) ( -- ) +." b1(;)" cr + rpop set-ip +; + +\ : b1(:) ( -- ) +\ ." b1(:)" cr +\ <colon> compile, get-ip 1+ literal ] get-ip rpush set-ip [ +\ ffwto; +\ ; immediate + +: b(;) ( -- ) + postpone exit 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 + +: 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 + 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 +; + +: named-token \ decide wether or not to give a new token an own name in the dictionary + fcode-debug? IF new-token ELSE external-token THEN + ; + +: b(to) ( x -- ) + next-ip read-fcode# + get-token drop + >body cell - + ?compile-mode IF literal, postpone ! ELSE ! THEN + ; immediate + +: b(value) + <value> , , reveal + ; + +: b(variable) + <variable> , 0 , reveal + ; + +: b(constant) + <constant> , , reveal + ; + +: undefined-defer + cr cr ." Unititialized defer word has been executed!" cr cr + true fcode-end ! + ; + +: b(defer) + <defer> , reveal + postpone undefined-defer + ; + +: b(create) + <variable> , + postpone noop reveal + ; + +: b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) + <colon> , over literal, + postpone + postpone exit + + + ; + +: b(buffer:) ( E: -- a-addr) ( F: size -- ) + <variable> , allot + ; + +: suspend-fcode ( -- ) + noop \ has to be implemented more efficiently ;-) + ; + +: offset16 ( -- ) + 16 to fcode-offset + ; + +: version1 ( -- ) + 1 to fcode-spread + 8 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@ + ; + +create byte-load-test-fcode +f1 c, 08 c, 18 c, 69 c, 00 c, 00 c, 00 c, 68 c, +12 c, 16 c, 62 c, 79 c, 74 c, 65 c, 2d c, 6c c, +6f c, 61 c, 64 c, 2d c, 74 c, 65 c, 73 c, 74 c, +2d c, 66 c, 63 c, 6f c, 64 c, 65 c, 21 c, 21 c, +90 c, 92 c, ( a6 c, a7 c, 2e c, ) 00 c, + +: byte-load-test + byte-load-test-fcode ['] w@ + ; immediate + +: fcode-ms + s" ms" $find IF 0= IF compile, ELSE execute THEN THEN ; immediate + +: fcode-$find + $find + IF + drop true + ELSE + false + THEN + ; + +( ---------------------------------------------------- ) diff --git a/slof/fs/fcode/big.fs b/slof/fs/fcode/big.fs new file mode 100644 index 0000000..00eb570 --- /dev/null +++ b/slof/fs/fcode/big.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 +\ ****************************************************************************/ + +\ big-endian + +( ---------------------------------------------------- ) + +: 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 @ + ; + +( ---------------------------------------------------- ) diff --git a/slof/fs/fcode/core.fs b/slof/fs/fcode/core.fs new file mode 100644 index 0000000..79d47c3 --- /dev/null +++ b/slof/fs/fcode/core.fs @@ -0,0 +1,169 @@ +\ ***************************************************************************** +\ * 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 16 = + ; + +: ?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 + ; + +-1 VALUE break-fcode-addr + +: exec ( FCode# -- ) + + eva-debug? IF + dup + get-ip 8 u.r ." : " + ." [" 3 u.r ." ] " + THEN + get-ip break-fcode-addr = IF + TRUE fcode-end ! drop EXIT + THEN + + get-token 0= IF \ imm == 0 == false + ?compile-mode IF + compile, + ELSE + eva-debug? IF dup xt>name type space THEN + execute + THEN + ELSE \ immediate + eva-debug? IF dup xt>name type space THEN + execute + THEN + eva-debug? IF .s cr THEN + ; + +( ---------------------------------------------------- ) + +0 ?bigendian INCLUDE? big.fs +0 ?bigendian NOT INCLUDE? little.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 + ; + +: evaluate-fcode ( -- ) + fcode@ exec \ read start code + BEGIN + next-ip fcode@ exec + fcode-end @ + UNTIL + ; + +: step-fcode ( -- ) + break-fcode-addr >r -1 to break-fcode-addr + fcode@ exec next-ip + r> to break-fcode-addr +; + + +( ---------------------------------------------------- ) diff --git a/slof/fs/fcode/evaluator.fs b/slof/fs/fcode/evaluator.fs new file mode 100644 index 0000000..1434098 --- /dev/null +++ b/slof/fs/fcode/evaluator.fs @@ -0,0 +1,99 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +( eva - gordons fcode bytecode evaluator ) + +hex + +-1 constant true + 0 constant false + +variable ip +variable fcode-end +variable fcode-num + 1 value fcode-spread +16 value fcode-offset +false value eva-debug? +false 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 + +0 value buff +0 value buff-size + +( ---------------------------------------------------- ) + +' read-fcode# to fcode@ + +: step next-ip fcode@ exec ; immediate +( ---------------------------------------------------- ) + +: rom-code-ignored ( image# name len -- ) + diagnostic-mode? IF type ." code found in image " . ." , ignoring ..." cr + ELSE 3drop THEN +; + +: pci-find-rom ( baseaddr -- addr ) + -8 and dup IF + dup rw@ 55aa = IF + diagnostic-mode? IF ." Device ROM found at " dup . cr THEN + ELSE drop 0 THEN + THEN +; + +: pci-find-fcode ( baseaddr -- addr len | false ) + pci-find-rom ?dup IF + dup 18 + rw@ wbflip + + 0 swap BEGIN + dup rl@ 50434952 ( 'PCIR') <> IF + diagnostic-mode? IF + ." Invalid PCI Data structure, ignoring ROM contents" cr + THEN + 2drop false EXIT + THEN + dup 14 + rb@ CASE + 0 OF over . s" Intel x86 BIOS" rom-code-ignored ENDOF + 1 OF swap diagnostic-mode? IF + ." Open Firmware FCode found at image " . cr + ELSE drop THEN + dup a + rw@ wbflip over + \ This code start + swap 10 + rw@ wbflip 200 * \ This code length + EXIT + ENDOF + 2 OF over . s" HP PA RISC" rom-code-ignored ENDOF + 3 OF over . s" EFI" rom-code-ignored ENDOF + dup OF over . s" Unknown type" rom-code-ignored ENDOF + ENDCASE + dup 15 + rb@ 80 and IF 2drop EXIT THEN \ End of last image + dup 10 + rw@ wbflip 200 * + \ Next image start + swap 1+ swap \ Next image # + 0 UNTIL + THEN false +; + +: execute-rom-fcode ( addr len | false -- ) + ?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 +; diff --git a/slof/fs/fcode/tokens.fs b/slof/fs/fcode/tokens.fs new file mode 100644 index 0000000..ad6c52b --- /dev/null +++ b/slof/fs/fcode/tokens.fs @@ -0,0 +1,411 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +: 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 ; + + +: 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 + +\ ' ferror 1 08 set-token +\ ' ferror 1 09 set-token +\ ' ferror 1 0a set-token +\ ' ferror 1 0b set-token +\ ' ferror 1 0c set-token +\ ' ferror 1 0d set-token +\ ' ferror 1 0e set-token +\ ' ferror 1 0f set-token + +' 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 +' l@ 0 6E set-token +' w@ 0 6F set-token +' <w@ 0 70 set-token +' c@ 0 71 set-token +' ! 0 72 set-token +' l! 0 73 set-token +' w! 0 74 set-token +' c! 0 75 set-token +' 2@ 0 76 set-token +' 2! 0 77 set-token +' move 0 78 set-token +' 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 \ alloc-mem +' free-mem 0 8C set-token \ free-mem +' 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 \ should be (cr but terminal support is not + \ available +' 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 +' $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 +\ ' ferror 0 B3 set-token +\ ' ferror 0 B4 set-token +' new-token 0 B5 set-token +' named-token 0 B6 set-token +\ fcode-debug? IF +' b(:) 1 B7 set-token +\ ELSE +\ ' b(:) 1 B7 set-token +\ THEN +' 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 +\ ' ferror 0 BF set-token +' INSTANCE 0 C0 set-token +\ ' noop 1 C0 set-token +\ ' ferror 0 C1 set-token +\ fcode-debug? IF +' b(;) 1 C2 set-token +\ ELSE +\ ' b(;) 1 C2 set-token +\ THEN +' 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 + +' start0 0 F0 set-token +' start1 0 F1 set-token +' start2 0 F2 set-token +' start4 0 F3 set-token + +' ferror 0 FC set-token +' version1 0 FD set-token + +\ ' 4-byte-id 0 FE set-token \ Historical +' end1 0 FF set-token + +\ ' dma-alloc 0 101 set-token +' my-address 0 102 set-token +' my-space 0 103 set-token +' 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 +' model 0 119 set-token +' device-type 0 11A set-token +' parse-2int 0 11B set-token +' is-install 0 11C set-token +' is-remove 0 11D set-token +' is-selftest 0 11E set-token +' new-device 0 11F set-token +' diagnostic-mode? 0 120 set-token +' memory-test-suite 0 122 set-token +' 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 +' #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 + +' 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-install 0 18B set-token + +' 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 +' my-unit 0 20D set-token +' $call-method 0 20E set-token +' $open-package 0 20F set-token +' (is-user-word) 0 214 set-token +' suspend-fcode 0 215 set-token +\ ' abort 0 216 set-token +' fc-abort 0 216 set-token +' catch 0 217 set-token +' throw 0 218 set-token +' 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 +' rx@ 0 22E set-token +' rx! 0 22F set-token +' rb@ 0 230 set-token +' rb! 0 231 set-token +' rw@ 0 232 set-token +' rw! 0 233 set-token +' rl@ 0 234 set-token +' rl! 0 235 set-token +' wbflips 0 236 set-token +' lwflips 0 237 set-token +\ ' probe 0 238 set-token +\ ' probe-virtual 0 239 set-token +\ 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 +' bxjoin 0 241 set-token +' <l@ 0 242 set-token +' lxjoin 0 243 set-token +' wxjoin 0 244 set-token +' x, 0 245 set-token +' x@ 0 246 set-token +' 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 254 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/slof/fs/find-hash.fs b/slof/fs/find-hash.fs new file mode 100644 index 0000000..a40ccbd --- /dev/null +++ b/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/slof/fs/generic-disk.fs b/slof/fs/generic-disk.fs new file mode 100644 index 0000000..0543c89 --- /dev/null +++ b/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/slof/fs/history.fs b/slof/fs/history.fs new file mode 100644 index 0000000..2c2c70f --- /dev/null +++ b/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/slof/fs/ide.fs b/slof/fs/ide.fs new file mode 100644 index 0000000..93ca766 --- /dev/null +++ b/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 occured + +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 occured 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/slof/fs/instance.fs b/slof/fs/instance.fs new file mode 100644 index 0000000..67c5b06 --- /dev/null +++ b/slof/fs/instance.fs @@ -0,0 +1,130 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ Support for device node instances. + +0 VALUE my-self + +: >instance + my-self 0= ABORT" No instance!" + my-self + +; + +: (create-instance-var) ( initial-value -- ) + get-node ?dup 0= ABORT" Instance word outside device context!" + dup node>instance @ ( iv phandle tmp-ihandle ) + 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 ; + +VOCABULARY instance-words ALSO instance-words DEFINITIONS + +: VARIABLE 0 create-instance-var DOES> @ >instance ; +: VALUE create-instance-var DOES> @ >instance @ ; +: DEFER 0 create-instance-var DOES> @ >instance @ execute ; +\ No support for BUFFER: yet. + +PREVIOUS DEFINITIONS + +\ 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 ! +; + +: 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 + +: INSTANCE ALSO instance-words ; + + +STRUCT +/n FIELD instance>node +/n FIELD instance>parent +/n FIELD instance>args +/n FIELD instance>args-len +CONSTANT /instance-header + +: my-parent my-self instance>parent @ ; +: my-args my-self instance>args 2@ ; + +\ 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 ) + swap 2dup \ | write the new address ( old-addr new-addr len new-addr len ) + my-self instance>args 2! \ | into the instance table ( old-addr new-addr len ) + 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 @ swap node>instance-size @ ( instance instance-size ) + dup alloc-mem dup >r swap move r> +; +: create-instance ( -- ) + my-self create-instance-data + dup to my-self instance>parent ! + get-node my-self instance>node ! +; + +: destroy-instance ( instance -- ) + dup @ node>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 push-my-self $call-my-method pop-my-self ; +: $call-parent my-parent $call-method ; diff --git a/slof/fs/little-endian.fs b/slof/fs/little-endian.fs new file mode 100644 index 0000000..cc9e7f2 --- /dev/null +++ b/slof/fs/little-endian.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 +\ ****************************************************************************/ + +deadbeef here l! +here c@ de = CONSTANT ?bigendian +here c@ ef = CONSTANT ?littleendian + + +?bigendian [IF] + +: l!-le >r lbflip r> l! ; +: l@-le l@ lbflip ; + +: w!-le >r wbflip r> w! ; +: w@-le w@ wbflip ; + +: 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] + +: l!-le l! ; +: l@-le l@ ; + +: w!-le w! ; +: w@-le w@ ; + +: 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/slof/fs/loaders.fs b/slof/fs/loaders.fs new file mode 100644 index 0000000..8bf8163 --- /dev/null +++ b/slof/fs/loaders.fs @@ -0,0 +1,92 @@ +\ ***************************************************************************** +\ * 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 -- ) + msr@ 2000 or ciregs >srr1 ! + dup 8 + @ ciregs >r2 ! @ call-client \ entry point is pointer to .opd +; + +10000000 VALUE LOAD-BASE +2000000 VALUE FLASH-LOAD-BASE + +: 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-elf-file drop 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 + s" ping" rot ['] $call-method CATCH IF + cr + ." Not a pingable device" + cr 3drop + THEN + 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 +; + +: modforth ( -- rc ) + romfs-base eregs 80 + ! + s" forth" (client-exec) +; diff --git a/slof/fs/logging.fs b/slof/fs/logging.fs new file mode 100644 index 0000000..4a31b50 --- /dev/null +++ b/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 -- ) +#ifndef DISABLE_NVRAM + 0 1 asm-cout +#else + drop +#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/slof/fs/node.fs b/slof/fs/node.fs new file mode 100644 index 0000000..8f587b2 --- /dev/null +++ b/slof/fs/node.fs @@ -0,0 +1,473 @@ +\ ***************************************************************************** +\ * 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. + +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 + 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" + +1000 CONSTANT max-instance-size +3000000 CONSTANT space-code-mask + +: create-node ( parent -- new ) + max-instance-size alloc-mem dup max-instance-size erase >r + align wordlist >r wordlist >r + here 0 , swap , 0 , r> , r> , r> , /instance-header , 0 , 0 , 0 , 0 , ; + +: 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 ( -- ) +\ we should resize the instance template buffer, but that doesn't help with our +\ current implementation of alloc-mem anyway, so never mind. XXX + 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-space ( -- phys.hi ) + my-self ihandle>phandle >space ; +: my-address my-self ihandle>phandle >address ; +: my-unit my-self ihandle>phandle >unit ; + +\ Return lower 64 bit of address +: my-unit-64 ( -- phys.lo+1|phys.lo ) + my-unit ( phys.lo ... phys.hi ) + my-self ihandle>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 ; + +\ 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@ ihandle>phandle node>qname $cat r> instance>args 2@ + 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 drop 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 ; + +: 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 begining 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-node ( node -- ) + cr $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 dup cr 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! ; +: open-node ( arg len phandle -- ihandle | 0 ) + current-node @ >r set-node create-instance set-my-args + ( and set unit-addr ) +\ XXX: assume default of success for nodes without open method + s" open" ['] $call-my-method CATCH IF 2drop true THEN + 0= IF my-self destroy-instance 0 to my-self THEN + my-self my-parent to my-self r> set-node + \ 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 node>instance @ dup to my-self instance>parent ! + get-node my-self instance>node ! ; +: finish-device ( -- ) + ( check for "name" property here, delete this node if not there ) + finish-node my-parent my-self max-instance-size free-mem to my-self ; + +: 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 ! ; + +: 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? ) + node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF + 2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true ; +: 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 -- ) + dup 0= IF to #search-unit drop 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 + ; +: find-component ( path len -- path' len' args len node|0 ) + [char] / split 2swap ( path'. component. ) + [char] : split 2swap ( path'. args. node-addr. ) + [char] @ split ['] set-search-unit CATCH IF 2drop 2drop 0 EXIT THEN + resolve-relatives find-kid ; + +: .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>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 ) + 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 ; + +: find-device ( str len -- ) \ set as active node + find-node dup 0= ABORT" No such device path" set-node ; +: dev skipws 0 parse 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 + +\ 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. +: find-package ( name len -- false | phandle true ) + 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/slof/fs/nvram.fs b/slof/fs/nvram.fs new file mode 100644 index 0000000..322d858 --- /dev/null +++ b/slof/fs/nvram.fs @@ -0,0 +1,189 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +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,BE0log" get-named-nvram-partition IF + s" ibm,CPU0log" get-named-nvram-partition IF + 2drop EXIT + THEN + THEN + drop .dmesg-part nip nip +; + +: dmesg2 ( -- ) + s" ibm,BE1log" get-named-nvram-partition IF + s" ibm,CPU1log" get-named-nvram-partition IF + ." No log partition." cr EXIT + THEN + THEN + drop .dmesg +; + +: dmesg ( -- ) + s" ibm,BE0log" get-named-nvram-partition IF + s" ibm,CPU0log" get-named-nvram-partition IF + ." No log partition." cr EXIT + THEN + THEN + drop .dmesg +; + diff --git a/slof/fs/packages.fs b/slof/fs/packages.fs new file mode 100644 index 0000000..a31be2e --- /dev/null +++ b/slof/fs/packages.fs @@ -0,0 +1,62 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ ============================================================================= +\ 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 + +\ new-device +\ #include "packages/scsi.fs" +\ finish-device + +new-device +#include "packages/bulk.fs" +finish-device + + diff --git a/slof/fs/packages/bulk.fs b/slof/fs/packages/bulk.fs new file mode 100644 index 0000000..06d7eae --- /dev/null +++ b/slof/fs/packages/bulk.fs @@ -0,0 +1,87 @@ +\ ***************************************************************************** +\ * 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" bulk" device-name + + +\ standard open firmare method + + +: open true ; + +\ standard open firmare method + + +: close ; + + +\ ------------------------------------------------- +\ Locals +\ ------------------------------------------------ + + +8 chars alloc-mem VALUE setup-packet + + +\ -------------------------------------------------- +\ signature --->4bytes offset --->0 +\ tag --->4bytes offset --->4 +\ trans-len --->4bytes offset --->8 +\ dir-flag --->1byte offset --->c +\ lun --->1byte offset --->d +\ comm-len --->1byte offset --->e +\ -------------------------------------------------- + + +0 VALUE cbw-addr +: build-cbw ( address tag transfer-len direction lun command-len -- ) + 5 pick TO cbw-addr ( address tag transfer-len direction lun command-len ) + cbw-addr 0f erase ( address tag transfer-len direction lun command-len ) + cbw-addr e + c! ( address tag transfer-len direction lun ) + cbw-addr d + c! ( address tag transfer-len direction ) + cbw-addr c + c! ( address tag transfer-len ) + cbw-addr 8 + l!-le ( address tag ) + cbw-addr 4 + l!-le ( address ) + 43425355 cbw-addr l!-le ( address ) + drop ; + + +\ --------------------------------------------------- +\ signature --->4bytes offset --->0 +\ tag --->4bytes offset --->4 +\ residue --->4bytes offset --->8 +\ status --->1byte offset --->c +\ --------------------------------------------------- + + +0 VALUE csw-addr +: analyze-csw ( address -- residue tag true|reason false ) + TO csw-addr + csw-addr l@-le 53425355 = IF + csw-addr c + c@ dup 0= IF ( reason ) + drop + csw-addr 8 + l@-le ( residue ) + csw-addr 4 + l@-le ( residue tag ) \ command block tag + TRUE ( residue tag TRUE ) + ELSE + FALSE ( reason FALSE ) + THEN + ELSE + FALSE ( FALSE ) + THEN + csw-addr 0c erase +; + +: bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- ) + s" bulk-reset-recovery-procedure" $call-parent +; diff --git a/slof/fs/packages/deblocker.fs b/slof/fs/packages/deblocker.fs new file mode 100644 index 0000000..0b29079 --- /dev/null +++ b/slof/fs/packages/deblocker.fs @@ -0,0 +1,61 @@ +\ ***************************************************************************** +\ * 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 + +: 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. + BEGIN len @ block-size @ >= WHILE + adr @ block+remainder drop len @ max-transfer @ min block-size @ / read-blocks + 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/slof/fs/packages/disk-label.fs b/slof/fs/packages/disk-label.fs new file mode 100644 index 0000000..ca4b5b4 --- /dev/null +++ b/slof/fs/packages/disk-label.fs @@ -0,0 +1,521 @@ +\ ***************************************************************************** +\ * 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 16384 blocks (8MB) +d# 16384 value max-prep-partition-blocks + +s" disk-label" device-name + +0 INSTANCE VALUE partition +0 INSTANCE VALUE part-offset + +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 + + +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 + + +\ Defined by IEEE 1275-1994 (3.8.1) + +: offset ( d.rel -- d.abs ) + part-offset 0 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 + d# 2048 alloc-mem + dup d# 2048 erase + to block + debug-disk-label? IF + ." init-block: block-size=" block-size .d ." block=0x" block u. cr + THEN +; + + +\ This word returns true if the currently loaded block has _NO_ MBR magic +: no-mbr? ( -- true|false ) + 0 read-sector 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 ) +; + +: 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 +; + +: 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 cr ." No DOS disk-label found." cr 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 drop + 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 begining 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. + +\ NOTE: block-size is always 512 bytes for DOS partition tables. + +: load-from-dos-boot-partition ( addr -- size ) + no-mbr? IF 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 +; + + +\ load from a bootable partition + +: load-from-boot-partition ( addr -- size ) + load-from-dos-boot-partition + \ More boot partition formats ... +; + + + +\ 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 [char] \ findchar drop ( addr1 len1 pos2 ) + dup >r - swap r> + swap ( addr2 len2 ) + 2dup s" </boot-script>" find-substr nip ( addr2 len3 ) +; + +\ 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-self parent ihandle>phandle node>path + s" :\ppc\bootinfo.txt" $cat strdup ( addr str len ) + 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 + \ Create the full path to the boot loader: + my-self parent ihandle>phandle node>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 ) +; + +\ 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 + + my-args to args-len to args + + \ Fix up the "0" thing yaboot does. + args-len 1 = IF args c@ [char] 0 = IF 0 to args-len THEN THEN + + \ Check for "full disk" arguments. + my-args [char] , findchar 0= IF true EXIT THEN drop \ no comma + 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 0 byte 0-2 is a jump instruction in all FAT + \ filesystems. + \ e9 and eb are jump instructions in x86 assembler. + block c@ e9 <> IF + block c@ eb <> + block 2+ c@ 90 <> or + IF false EXIT THEN + 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-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 d# 2048 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 + 200000 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/slof/fs/packages/ext2-files.fs b/slof/fs/packages/ext2-files.fs new file mode 100644 index 0000000..454e919 --- /dev/null +++ b/slof/fs/packages/ext2-files.fs @@ -0,0 +1,140 @@ +\ ***************************************************************************** +\ * 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" ext2-files" device-name + +INSTANCE VARIABLE first-block +INSTANCE VARIABLE block-size +INSTANCE VARIABLE inodes/group + +INSTANCE VARIABLE group-descriptors + +: 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" 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# -- ) +\ TBD +; +: read-triple-indirect-blocks ( triple-indirect-block# -- ) +\ TBD +; +: 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 80 * + xlsplit seek drop inode @ 80 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 ! + first-block @ 1+ read-block data @ group-descriptors ! 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 ; +: open + do-super + 80 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/slof/fs/packages/fat-files.fs b/slof/fs/packages/fat-files.fs new file mode 100644 index 0000000..76d9f51 --- /dev/null +++ b/slof/fs/packages/fat-files.fs @@ -0,0 +1,187 @@ +\ ***************************************************************************** +\ * 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 ." slash " 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> ." more... " RECURSE EXIT THEN + 2r> 2drop true ." got it " ; + +: 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 ! +cr ." FAT" base @ decimal fat-type @ . 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 ) + 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/slof/fs/packages/filler.fs b/slof/fs/packages/filler.fs new file mode 100644 index 0000000..bd5c17a --- /dev/null +++ b/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/slof/fs/packages/iso-9660.fs b/slof/fs/packages/iso-9660.fs new file mode 100644 index 0000000..6db3d8d --- /dev/null +++ b/slof/fs/packages/iso-9660.fs @@ -0,0 +1,307 @@ +\ ***************************************************************************** +\ * 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 ! 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 -- ) + free-data DUP ( offset size size ) + #data ! alloc-mem data-buff ! ( offset ) + xlsplit ( pos.lo pos.hi ) + seek -2 and ABORT" seek failed." + data-buff @ #data @ read ( actual ) + #data @ <> 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 ) + dup -rot - >r + r> erase ( str' len' ) + 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@ str= 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 invert IF ( str len ) + 2dup ( str len str len ) + I 21 + I 20 + c@ ( str len str len str' len' ) + file-name str= 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 + I c@ dup 0= IF ( str len len ) + s" file not found" iso-debug-print + drop 2drop FALSE ( FALSE ) + UNLOOP + EXIT + THEN + +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/slof/fs/packages/obp-tftp.fs b/slof/fs/packages/obp-tftp.fs new file mode 100644 index 0000000..6bb43c9 --- /dev/null +++ b/slof/fs/packages/obp-tftp.fs @@ -0,0 +1,73 @@ +\ ***************************************************************************** +\ * 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 + s" /chosen" select-dev + dup 6B8 encode-bytes s" bootp-response" property + device-end + + \ free buffer + 6B8 free-mem +; + +: close ( -- ) + ciregs-buffer @ ciregs-size free-mem +; + +: ping ( -- ) + s" ping " my-args $cat (client-exec) +; diff --git a/slof/fs/packages/rom-files.fs b/slof/fs/packages/rom-files.fs new file mode 100644 index 0000000..418cf4e --- /dev/null +++ b/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/slof/fs/packages/sms.fs b/slof/fs/packages/sms.fs new file mode 100644 index 0000000..d8c672f --- /dev/null +++ b/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/slof/fs/pci-bridge.fs b/slof/fs/pci-bridge.fs new file mode 100644 index 0000000..81bfca1 --- /dev/null +++ b/slof/fs/pci-bridge.fs @@ -0,0 +1,62 @@ +\ ***************************************************************************** +\ * 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 +s" my-puid" $call-parent CONSTANT my-puid +\ Save the bus number provided by this bridge +pci-bus-number 1+ CONSTANT my-bus + +s" pci-config-bridge.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/slof/fs/pci-class-code-names.fs b/slof/fs/pci-class-code-names.fs new file mode 100644 index 0000000..4156fba --- /dev/null +++ b/slof/fs/pci-class-code-names.fs @@ -0,0 +1,263 @@ +\ ***************************************************************************** +\ * 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 + 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/slof/fs/pci-config-bridge.fs b/slof/fs/pci-config-bridge.fs new file mode 100644 index 0000000..f813431 --- /dev/null +++ b/slof/fs/pci-config-bridge.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 +\ ****************************************************************************/ + +\ 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 ; + +\ 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.hi size -- virt ) + \ ." map-in called: " .s cr + 2drop drop +; + +: 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/slof/fs/pci-device.fs b/slof/fs/pci-device.fs new file mode 100644 index 0000000..fbb4c61 --- /dev/null +++ b/slof/fs/pci-device.fs @@ -0,0 +1,101 @@ +\ ***************************************************************************** +\ * 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 +s" my-puid" $call-parent 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 +; + +\ 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/slof/fs/pci-properties.fs b/slof/fs/pci-properties.fs new file mode 100644 index 0000000..312f431 --- /dev/null +++ b/slof/fs/pci-properties.fs @@ -0,0 +1,650 @@ +\ ***************************************************************************** +\ * 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-mem \ var to change + 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-mmio \ var to change + 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 + 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 2dup device-name device-type + 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 +; + +\ 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 + pci-bridge-interrupt-map + pci-reg-props +; + +\ FIXME still used in the device files slof/fs/devices/pci-device +: assign-bar-mapping ( bar-offset size var -- ) + rot my-unit-64 + -rot + assign-bar-value32 drop +; + +\ FIXME this is still used by the devices in slof/fs/devices/pci-device_* +: assigned-addresses-property ( -- ) + my-unit-64 + dup pci-common-props + pci-device-assigned-addresses-prop +; + +\ 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 +; + +\ 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 pci-device-props \ and generate all properties + drop \ forget the config-addr +; diff --git a/slof/fs/pci-scan.fs b/slof/fs/pci-scan.fs new file mode 100644 index 0000000..454631e --- /dev/null +++ b/slof/fs/pci-scan.fs @@ -0,0 +1,495 @@ +\ ***************************************************************************** +\ * 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 + +\ 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 + + +\ 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 ; + +\ ---------------------------------------------------------- +\ ****************** 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 +; + +\ 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 +: 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 +; + +\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\ the following functions use l@ to fetch the data, +\ that's because the pcie core on spider has some 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? ; + +\ 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! ; + +\ 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-mem-access ( -- ) pci-mem-enable ; + +\ 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-io-access ( -- ) pci-io-enable ; + +\ 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 +; + +\ 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 pci-next-mmio ! \ and write it back + 10 rshift \ mmio-base reg is only the upper 16 bits + pci-max-mmio @ 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 pci-next-mem ! \ and write it back + over 24 + rtas-config-w@ \ check if 64bit support + 1 and IF \ IF 64 bit support + 2dup 20 rshift \ | keep upper 32 bits + swap 28 + rtas-config-l! \ | and write it into the Base-Upper32-bits + pci-max-mem @ 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 @ 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 + 2dup 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 pci-next-io ! \ and write it back + 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 @ 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 + +\ 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 + 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 + 1 and IF \ IF BRIDGE + pci-bridge-setup \ | set up the bridge + ELSE \ ELSE + pci-device-setup \ | set up the device + THEN \ FI + 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 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 + + 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 + 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" + diff --git a/slof/fs/preprocessor.fs b/slof/fs/preprocessor.fs new file mode 100644 index 0000000..a13fb30 --- /dev/null +++ b/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/slof/fs/property.fs b/slof/fs/property.fs new file mode 100644 index 0000000..c02a07d --- /dev/null +++ b/slof/fs/property.fs @@ -0,0 +1,189 @@ +\ ***************************************************************************** +\ * 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 lenght + 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 0= + IF + nip nip 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/slof/fs/quiesce.fs b/slof/fs/quiesce.fs new file mode 100644 index 0000000..3b2dee9 --- /dev/null +++ b/slof/fs/quiesce.fs @@ -0,0 +1,54 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +10 CONSTANT quiesce-xt# + +\ The array with the quiesce execution tokens: +CREATE quiesce-xts quiesce-xt# cells allot +quiesce-xts quiesce-xt# cells erase + + +\ 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-xt# 0 DO + quiesce-xts I cells + ( arrayptr ) + @ dup IF ( xt ) + EXECUTE + ELSE + drop UNLOOP EXIT + THEN + LOOP +; + diff --git a/slof/fs/rmove.fs b/slof/fs/rmove.fs new file mode 100644 index 0000000..c28dba9 --- /dev/null +++ b/slof/fs/rmove.fs @@ -0,0 +1,53 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +defer '(r@) +defer '(r!) +1 VALUE /(r) + + +\ The rest of the code already implemented in prim.in +\ In the end all of this should be moved over there and this file terminated + +: (rfill) ( addr size pattern 'r! /r -- ) + to /(r) to '(r!) ff and + dup 8 lshift or dup 10 lshift or dup 20 lshift or + -rot bounds ?do dup i '(r!) /(r) +loop drop +; + +: (fwrmove) ( src dest size -- ) + >r 0 -rot r> bounds ?do + dup '(r@) i '(r!) /(r) dup +loop 2drop +; + +\ Move from main to device memory +: mrmove ( src dest size -- ) + 3dup or or 7 AND CASE + 0 OF ['] x@ ['] rx! /x ENDOF + 4 OF ['] l@ ['] rl! /l ENDOF + 2 OF ['] w@ ['] rw! /w ENDOF + dup OF ['] c@ ['] rb! /c ENDOF + ENDCASE + ( We already know that source and destination do not overlap ) + to /(r) to '(r!) to '(r@) (fwrmove) +; + +: rfill ( addr size pattern -- ) + 3dup drop or 7 AND CASE + 0 OF ['] rx! /x ENDOF + 4 OF ['] rl! /l ENDOF + 2 OF ['] rw! /w ENDOF + dup OF ['] rb! /c ENDOF + ENDCASE (rfill) +; + + + diff --git a/slof/fs/romfs.fs b/slof/fs/romfs.fs new file mode 100644 index 0000000..7d7e463 --- /dev/null +++ b/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/slof/fs/root.fs b/slof/fs/root.fs new file mode 100644 index 0000000..429b77e --- /dev/null +++ b/slof/fs/root.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 +\ ****************************************************************************/ + +\ 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 + +: set-chosen ( prop len name len -- ) + s" /chosen" find-node set-property ; + +: get-chosen ( name len -- [ prop len ] success ) + s" /chosen" find-node get-property 0= ; + +new-device + s" /" device-name + new-device + s" chosen" device-name + s" " encode-string s" bootargs" property + s" " encode-string s" bootpath" property + finish-device + + new-device + s" aliases" device-name + finish-device + + new-device + s" options" device-name + finish-device + + + new-device + s" openprom" device-name + s" BootROM" device-type + finish-device + + new-device +#include <packages.fs> + finish-device + +: open true ; +: close ; + +finish-device diff --git a/slof/fs/rtas/rtas-cpu.fs b/slof/fs/rtas/rtas-cpu.fs new file mode 100644 index 0000000..c133abc --- /dev/null +++ b/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/slof/fs/rtas/rtas-flash.fs b/slof/fs/rtas/rtas-flash.fs new file mode 100644 index 0000000..f8abeaa --- /dev/null +++ b/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/slof/fs/rtas/rtas-init.fs b/slof/fs/rtas/rtas-init.fs new file mode 100644 index 0000000..8451cfd --- /dev/null +++ b/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/slof/fs/rtas/rtas-reboot.fs b/slof/fs/rtas/rtas-reboot.fs new file mode 100644 index 0000000..a9539ec --- /dev/null +++ b/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/slof/fs/rtas/rtas-vpd.fs b/slof/fs/rtas/rtas-vpd.fs new file mode 100644 index 0000000..7fb4b54 --- /dev/null +++ b/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/slof/fs/scsi-loader.fs b/slof/fs/scsi-loader.fs new file mode 100644 index 0000000..406c184 --- /dev/null +++ b/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 atributes 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/slof/fs/scsi-support.fs b/slof/fs/scsi-support.fs new file mode 100644 index 0000000..7e4fd05 --- /dev/null +++ b/slof/fs/scsi-support.fs @@ -0,0 +1,781 @@ +\ ***************************************************************************** +\ * 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: 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>ASCQ c@ ( ascq ) + r@ sense-data>ASC c@ ( ascq asc ) + r> sense-data>sense-key c@ 0f and ( ascq asc sense-key ) ( R: addr -- ) +; + +\ -------------------------------------------------------------------------- +\ 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 70 = \ 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 +; + +\ *************************************************************************** +\ 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) +; + + +\ *************************************************************************** +\ 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 preceeding '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 occured ? + IF + cr ." ** WARNING: " scsi-param-errors .d + ." SCSI Errors occured ** " 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/slof/fs/search.fs b/slof/fs/search.fs new file mode 100644 index 0000000..3acca2f --- /dev/null +++ b/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/slof/fs/slof-logo.fs b/slof/fs/slof-logo.fs new file mode 100644 index 0000000..53d3184 --- /dev/null +++ b/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/slof/fs/sms/sms-load.fs b/slof/fs/sms/sms-load.fs new file mode 100644 index 0000000..8e4db80 --- /dev/null +++ b/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/slof/fs/sms/sms-nvram.fs b/slof/fs/sms/sms-nvram.fs new file mode 100644 index 0000000..4f5d6dd --- /dev/null +++ b/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/slof/fs/stack.fs b/slof/fs/stack.fs new file mode 100644 index 0000000..0f7e097 --- /dev/null +++ b/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/slof/fs/start-up.fs b/slof/fs/start-up.fs new file mode 100644 index 0000000..0ce0f3c --- /dev/null +++ b/slof/fs/start-up.fs @@ -0,0 +1,92 @@ +\ ***************************************************************************** +\ * 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 drop (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? + + +: start-it ( -- ) + key? IF + key CASE + [char] s OF (s-pressed) ENDOF + 1b OF + + (esc-sequence) CASE + 1 OF console-clean-fifo sms-start (boot) 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/slof/fs/term-io.fs b/slof/fs/term-io.fs new file mode 100644 index 0000000..1ab9f94 --- /dev/null +++ b/slof/fs/term-io.fs @@ -0,0 +1,92 @@ +\ ***************************************************************************** +\ * 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 + 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 +\ 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/slof/fs/terminal.fs b/slof/fs/terminal.fs new file mode 100644 index 0000000..3004265 --- /dev/null +++ b/slof/fs/terminal.fs @@ -0,0 +1,196 @@ +\ ***************************************************************************** +\ * 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 + +: ansi-esc ( char -- ) + csi-on IF + dup [char] 0 [char] 9 between IF set-esc-parm + ELSE 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 0 get-esc-parm to esc-num-parm2 ENDOF + [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 0<> to inverse? 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 false to csi-on + false to esc-on 0 to esc-num-parm 0 to esc-num-parm2 + 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 + +: 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 + 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/slof/fs/timebase.fs b/slof/fs/timebase.fs new file mode 100644 index 0000000..863f694 --- /dev/null +++ b/slof/fs/timebase.fs @@ -0,0 +1,19 @@ +\ ***************************************************************************** +\ * 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 + +: milliseconds ( -- ms ) tbl@ d# 1000 * tb-frequency / ; +: microseconds ( -- us ) tbl@ 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/slof/fs/translate.fs b/slof/fs/translate.fs new file mode 100644 index 0000000..e2633e5 --- /dev/null +++ b/slof/fs/translate.fs @@ -0,0 +1,152 @@ +\ ***************************************************************************** +\ * 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 8 + ( prop_type address data address data' ) + 2dup l@ 2 pick 8 + l@ + <= -rot l@ >= and IF + l@ 03000000 and 18 rshift nip + \ no 64bit translations supported pretend it is 32bit + dup 3 = IF 1- THEN + ( 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/slof/fs/update_flash.fs b/slof/fs/update_flash.fs new file mode 100644 index 0000000..495e15f --- /dev/null +++ b/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 load-base over flash-image-size rmove true + ELSE + false + THEN +; + +: flash-read-perm ( -- success? ) + get-flashside 0= IF + flash-addr 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 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 + + load-base flash-write 0= IF ." Flash write failed !! " cr THEN + r> set-flashside drop \ Restore old flashside +; diff --git a/slof/fs/usb/usb-enumerate.fs b/slof/fs/usb/usb-enumerate.fs new file mode 100644 index 0000000..7118f17 --- /dev/null +++ b/slof/fs/usb/usb-enumerate.fs @@ -0,0 +1,324 @@ +\ ***************************************************************************** +\ * 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 the device tree for hub + +: (hub-create) ( -- ) + mps port-number new-device-address port-number + ( mps port-number usb-address port-number ) + new-device set-space ( mps port-number usb-address ) + encode-int s" USB-ADDRESS" property ( mps port-number ) + s" Address Set" usb-debug-print + encode-int s" reg" property ( mps ) + s" Port Number Set" usb-debug-print + encode-int s" MPS-DCP" property + s" MPS Set" usb-debug-print + s" usb-hub.fs" INCLUDED + s" Driver Included" usb-debug-print + finish-device +; + + +\ encode properties for scsi or atapi device + +: (atapi-scsi-property-set) ( -- ) + dd-buffer @ e + c@ ( Manuf ) + dd-buffer @ f + c@ ( Manuf Prod ) + dd-buffer @ 10 + c@ ( Manuf Prod Serial-Num ) + cd-buffer @ 16 + w@-le ( Manuf Prod Serial-Num ep-mps ) + cd-buffer @ 14 + c@ ( Manuf Prod Serial-Num ep-mps ep-addr ) + cd-buffer @ 1d + w@-le ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ) + cd-buffer @ 1b + c@ ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr ) + mps port-number new-device-address port-number + ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr + mps port-num usb-addr port-num ) + new-device set-space + ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr + mps port-num usb-addr ) + encode-int s" USB-ADDRESS" property + ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr + mps port-num ) + encode-int s" reg" property + ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr + mps ) + encode-int s" MPS-DCP" property + ( Manuf Prod Serial-Num ep-mps ep-addr ep-mps ep-addr ) + 2 0 DO + dup 80 and IF + 7f and encode-int + s" BULK-IN-EP-ADDR" property + encode-int s" MPS-BULKIN" property + ELSE + encode-int s" BULK-OUT-EP-ADDR" property + encode-int s" MPS-BULKOUT" property + THEN + LOOP ( Manuf Prod Serial-Num ) + encode-int s" iSerialNumber" property ( Manuf Prod ) + encode-int s" iProduct" property ( Manuf ) + encode-int s" iManufacturer" property +; + + +\ To classify device as hub/atapi/scsi/HID device + +: (device-classify) + ( -- Interface-protocol Interface-subclass Interface-class TRUE|FALSE ) + cd-buffer @ BULK-CONFIG-DESCRIPTOR-LEN erase + cd-buffer @ BULK-CONFIG-DESCRIPTOR-LEN mps new-device-address + ( buffer descp-len mps usb-address ) + control-std-get-configuration-descriptor + IF + cd-buffer @ 1+ c@ ( Descriptor-type ) + 2 = IF + cd-buffer @ 10 + c@ ( protocol ) + cd-buffer @ f + c@ ( protocol subclass ) + cd-buffer @ e + c@ ( protocol subclass class ) + TRUE + ELSE + s" Not a valid configuration descriptor!!" usb-debug-print + FALSE + THEN + ELSE + s" Unable to read configuration descriptor!!" usb-debug-print + FALSE + THEN +; + + +\ create device tree for Atapi SFF-8020 device + +: (atapi-8020-create) ( -- ) + (atapi-scsi-property-set) + s" usb-storage.fs" INCLUDED + finish-device +; + +\ create device tree for Atapi SFF-8070 device + +: (atapi-8070-create) ( -- ) + (atapi-scsi-property-set) + s" usb-storage.fs" INCLUDED + \ s" storage" device-name + finish-device +; + + +\ create device tree for SCSI device + +: (scsi-create) ( -- ) + s" SCSI-CREATE " usb-debug-print + +\ *********************************************************************** +\ a problem was encountered on Media-Tray (REV-0): +\ The CDROM is connected to USB via an ATA/USB-Bridge (U38: CYPRESS CY7C68300) +\ The C-Revision of this chip has an malfunction which results in a +\ hanging IORD Signal at the ATA-Interface and so prevents from reading. +\ The B-Revision doesn't have this problem (populated on Media-Tray REV-5) +\ Two additional Mass-Storage-Resets are necessary to reset the ATA-Interface. +\ (see CYPRESS Application Notes to CY7C68300) +\ (see USB-Spec: 'Bulk-Only-Transport') +\ *********************************************************************** +\ a mounted ISO image (via USB) doesn't accept this bulk-reset-command! +\ *********************************************************************** + + dd-buffer @ 8 + w@-le 4b4 = \ VendorID = CYPRESS ? + IF + dd-buffer @ a + w@-le 6830 = \ Device = CY7C68300 ? + IF + \ here a Cypress ATA/USB Bridge is detected + d# 20 ms + mps new-device-address 0 0 0 ( MPS fun-addr dir data-buff data-len ) + control-bulk-reset ( TRUE|FALSE ) + d# 100 ms + mps new-device-address 0 0 0 ( TRUE|FALSE MPS fun-addr dir data-buff data-len ) + control-bulk-reset ( TRUE|FALSE TRUE|FALSE ) + and invert + IF + ." ** BULK-RESET failed **" cr + THEN + d# 20 ms + THEN + THEN + + 0 ch-buffer ! \ preset a clean response + mps new-device-address 0 ch-buffer 1 control-std-get-maxlun ( TRUE|FALSE ) + IF +\ s" GET-MAX-LUN IS WORKING :" usb-debug-print +\ ch-buffer 5 dump cr \ dump the responsed message + ELSE + s" ERROR in GET-MAX-LUN " usb-debug-print + 0 ch-buffer ! \ clear invalid numbers + cd-buffer @ 5 + c@ to temp1 + temp1 new-device-address control-std-set-configuration drop + THEN + \ FIXME: an IBM external HDD reported a number of 127 LUNs which could + \ not be set up. We need to understand how to set up the device + \ to report the correct number of LUNs. + \ The USB Massbulk Standard 1.0 defines a maximum of 15 mult. LUNs. + \ Workaround: Devices that might report a higher number are treated + \ as having exactly one LUN. Without this workaround the + \ USB scan hangs during the setup of non-available LUNs. + \ + \ Concerns: "FUJITSU MHV2040AT" (VendorID: 0x984 / DeviceID: 0x70) + \ + \ MR: This Device reports an invalid MaxLUN number within the first + \ three seconds after power-on or USB-Reset. The following loop repeats + \ the MaxLUN request up to 8 times until a valid ( <15 ) value is responded. + \ This can last up to four seconds as there is a delay of 500ms in every loop + + 0 ( counter ) + begin + dup 8 < ( counter flag ) \ max 8 * 500 ms + ch-buffer c@ f > ( counter flag flag ) \ is MuxLUN above limit ? + AND ( counter flag ) + while + d# 500 ms \ this device is not yet ready + 0 ch-buffer ! \ preset a clean response + mps new-device-address 0 ch-buffer 1 control-std-get-maxlun ( TRUE|FALSE ) + not + IF + s" ** ERROR in GET-MAX-LUN ** " usb-debug-print + drop 10 \ replace counter to force loop end + THEN + 1+ ( counter+1 ) + repeat + drop + + \ here is still the workaround to handle invalid MaxLUNs as '0' + \ + ch-buffer c@ dup 0= swap f > or IF + s" + LUN: " ch-buffer c@ usb-debug-print-val + (atapi-scsi-property-set) + s" usb-storage.fs" INCLUDED + finish-device + + ELSE + s" - LUN: " ch-buffer c@ usb-debug-print-val + (atapi-scsi-property-set) + s" usb-storage-wrapper.fs" INCLUDED + finish-device + + THEN +; + + +\ Classify USB storage device by sub-class code + +: (classify-storage) ( interface-protocol interface-subclass -- ) + s" USB: Mass Storage Device Found!" usb-debug-print + swap 50 <> IF + s" USB storage: Protocol is not 50." usb-debug-print + drop EXIT + THEN + ( interface-subclass ) + CASE + 02 OF (atapi-8020-create) s" ATAPI Interface " usb-debug-print ENDOF + 05 OF (atapi-8070-create) s" ATAPI Interface " usb-debug-print ENDOF + 06 OF (scsi-create) s" SCSI Interface " usb-debug-print ENDOF + dup OF s" USB storage: Unsupported sub-class code." usb-debug-print ENDOF + ENDCASE +; + + +\ create keyboard device tree + +: (keyboard-create) ( -- ) + cd-buffer @ 1f + c@ ( ep-mps ) + cd-buffer @ 1d + c@ ( ep-mps ep-addr ) + mps port-number new-device-address port-number + ( ep-mps ep-addr mps port-num usb-addr port-num ) + new-device set-space ( ep-mps ep-addr mps port-num usb-addr ) + encode-int s" USB-ADDRESS" property ( ep-mps ep-addr mps port-num ) + encode-int s" reg" property ( ep-mps ep-addr mps ) + encode-int s" MPS-DCP" property ( ep-mps ep-addr ) + 7f and encode-int s" INT-IN-EP-ADDR" property + encode-int s" MPS-INTIN" property + new-device-address \ device-speed + s" usb-keyboard.fs" INCLUDED + finish-device +; + +: (mouse-create) ( -- ) + mps port-number new-device-address port-number + ( mps port-num usb-addr port-num ) + new-device set-space ( mps port-num usb-addr ) + encode-int s" USB-ADDRESS" property ( mps port-num ) + encode-int s" reg" property ( mps ) + encode-int s" MPS-DCP" property + s" usb-mouse.fs" INCLUDED + finish-device +; + + +\ Classify by interface class code + +: (classify-by-interface) ( -- ) + (device-classify) IF + ( Interface-protocol Interface-subclass Interface-class ) + CASE + 08 OF + ( Interface-protocol Interface-subclass ) + (classify-storage) + ENDOF + 03 OF + ( Interface-protocol Interface-subclass ) + s" USB: HID Found!" usb-debug-print + 01 = + IF + case + 01 of + s" USB keyboard!" usb-debug-print + (keyboard-create) + endof + 02 of + s" USB mouse!" usb-debug-print + (mouse-create) + endof + dup of + s" USB: unsupported HID!" usb-debug-print + endof + endcase + ELSE + s" USB: unsupported HID!" usb-debug-print + THEN + ENDOF + dup OF + ( Interface-protocol Interface-subclass ) + s" USB: unsupported interface type." usb-debug-print + 2drop + ENDOF + ENDCASE + THEN +; + + +\ create usb device tree depending upon classification of the device +\ after encoding apt properties + +: create-usb-device-tree ( -- ) + dd-buffer @ DEVICE-DESCRIPTOR-DEVCLASS-OFFSET + c@ ( Device-class ) + CASE + HUB-DEVICE-CLASS OF s" USB: HUB found" usb-debug-print + (hub-create) + ENDOF + NO-CLASS OF + \ In this case, the INTERFACE descriptor + \ tells you whats what -- Refer USB spec. + (classify-by-interface) + ENDOF + DUP OF + s" USB: Unknown device found." usb-debug-print + ENDOF + ENDCASE + uDOC-present 0f and to uDOC-present \ remove uDOC processing flag +; diff --git a/slof/fs/usb/usb-hub.fs b/slof/fs/usb/usb-hub.fs new file mode 100644 index 0000000..106b680 --- /dev/null +++ b/slof/fs/usb/usb-hub.fs @@ -0,0 +1,459 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ ---------------------------------------------------------------------------- +\ On detection of a hub after reading the device descriptor this package has to +\ be called so that the hub enumeration is done to idenitify the down stream +\ device +\ -------------------------------------------------------------------------- +\ OF properties +\ -------------------------------------------------------------------------- + + +s" hub" device-name +s" usb" device-type +1 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + +\ converts physical address to text unit string + + +: encode-unit ( port-addr -- unit-str unit-len ) 1 hex-encode-unit ; + + +\ Converts text unit string to phyical address + + +: decode-unit ( addr len -- port-addr ) 1 hex-decode-unit ; + +0 VALUE new-device-address +0 VALUE port-number +0 VALUE MPS-DCP +0 VALUE mps +0 VALUE my-usb-address + +00 value device-speed + + +\ Get parameters passed from the parent. + +: mps-property-set ( -- ) + s" HUB Compiling mps-property-set " usb-debug-print + s" USB-ADDRESS" get-my-property ( TRUE | prop-addr prop-len FALSE ) + IF + s" notpossible" usb-debug-print + ELSE + decode-int nip nip to my-usb-address + THEN + s" MPS-DCP" get-my-property ( TRUE | prop-addr prop-len FALSE ) + IF + s" MPS-DCP property not found Assuming 8 as MAX PACKET SIZE" ( str len ) + usb-debug-print + s" for the default control pipe" usb-debug-print + 8 to MPS-DCP + ELSE + s" MPS-DCP property found!!" usb-debug-print ( prop-addr prop-len FALSE ) + decode-int nip nip to MPS-DCP + THEN +; + + +\ -------------------------------------------------------------------------- +\ Constant declarations +\ -------------------------------------------------------------------------- + + +2303080000000000 CONSTANT hppwr-set +2301080000000000 CONSTANT hppwr-clear +2303040000000000 CONSTANT hprst-set +A300000000000400 CONSTANT hpsta-get +2303010000000000 CONSTANT hpena-set +A006002900000000 CONSTANT hubds-get +8 CONSTANT DEFAULT-CONTROL-MPS +12 CONSTANT DEVICE-DESCRIPTOR-LEN +9 CONSTANT CONFIG-DESCRIPTOR-LEN +20 CONSTANT BULK-CONFIG-DESCRIPTOR-LEN + + +\ TODO: +\ CONFIG-DESCRIPTOR-LEN should be only 9. The interface +\ and endpoint descriptors returned along with config +\ descriptor are variable and 0x19 is a very wrong VALUE +\ to specify for this #define. + + +1 CONSTANT DEVICE-DESCRIPTOR-TYPE +1 CONSTANT DEVICE-DESCRIPTOR-TYPE-OFFSET +4 CONSTANT DEVICE-DESCRIPTOR-DEVCLASS-OFFSET +7 CONSTANT DEVICE-DESCRIPTOR-MPS-OFFSET +9 CONSTANT HUB-DEVICE-CLASS +0 CONSTANT NO-CLASS + + +\ -------------------------------------------------------------------------- +\ Temporary Variable declarations +\ -------------------------------------------------------------------------- + +00 VALUE temp1 +00 VALUE temp2 +00 VALUE temp3 +00 VALUE po2pg \ Power On to Power Good + + +\ -------------------------------------------------------------------------- +\ Buffer allocations +\ -------------------------------------------------------------------------- + + +VARIABLE setup-packet \ 8 bytes for setup packet +VARIABLE ch-buffer \ 1 byte character buffer + +INSTANCE VARIABLE dd-buffer +INSTANCE VARIABLE cd-buffer + +\ TODO: +\ Should arrive a proper value for the size of the "cd-buffer" + +8 chars alloc-mem VALUE status-buffer +9 chars alloc-mem VALUE hd-buffer + + +: (allocate-mem) ( -- ) + DEVICE-DESCRIPTOR-LEN chars alloc-mem dd-buffer ! + BULK-CONFIG-DESCRIPTOR-LEN chars alloc-mem cd-buffer ! +; + + +: (de-allocate-mem) ( -- ) + dd-buffer @ ?dup IF + DEVICE-DESCRIPTOR-LEN free-mem + 0 dd-buffer ! + THEN + cd-buffer @ ?dup IF + BULK-CONFIG-DESCRIPTOR-LEN free-mem + 0 cd-buffer ! + THEN +; + + +\ standard open firmware methods + +: open ( -- TRUE ) + (allocate-mem) + TRUE +; + +: close ( -- ) + (de-allocate-mem) +; + + +\ -------------------------------------------------------------------------- +\ Parent's method +\ -------------------------------------------------------------------------- + + +: controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE|FALSE ) + s" controlxfer" $call-parent +; + +: control-std-set-address ( speedbit -- usb-address TRUE|FALSE ) + s" control-std-set-address" $call-parent +; + +: control-std-get-device-descriptor + ( data-buffer data-len MPS funcAddr -- TRUE|FALSE ) + s" control-std-get-device-descriptor" $call-parent +; + +: control-std-get-configuration-descriptor + ( data-buffer data-len MPS funcAddr -- TRUE|FALSE ) + s" control-std-get-configuration-descriptor" $call-parent +; + +: control-std-get-maxlun + ( MPS fun-addr dir data-buff data-len -- TRUE|FALSE ) + s" control-std-get-maxlun" $call-parent +; + +: control-std-set-configuration + ( configvalue FuncAddr -- TRUE|FALSE ) + s" control-std-set-configuration" $call-parent +; + +: control-std-get-string-descriptor + ( StringIndex data-buffer data-len MPS FuncAddr -- TRUE|FALSE ) + s" control-std-get-string-descriptor" $call-parent +; + +: rw-endpoint + ( pt ed-type toggle buffer length mps address -- toggle TRUE|toggle FALSE ) + s" rw-endpoint" $call-parent +; + +: debug-td ( -- ) + s" debug-td" $call-parent +; + +\ *** NEW **** +: control-bulk-reset ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE ) + s" control-bulk-reset" $call-parent +; + + +\ -------------------------------------------------------------------------- +\ HUB specific methods +\ -------------------------------------------------------------------------- +\ To bring on the power on a valid port of a hub with a valid USB address +\ -------------------------------------------------------------------------- + + +: control-hub-port-power-set ( port# -- TRUE|FALSE ) + hppwr-set setup-packet ! ( port#) + setup-packet 4 + c! + 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE | FALSE ) +; + + +\ -------------------------------------------------------------------------- +\ To put power off on ports where device detection or enumeration has failed +\ -------------------------------------------------------------------------- + + +: control-hub-port-power-clear ( port#-- TRUE|FALSE ) + hppwr-clear setup-packet ! ( port#) + setup-packet 4 + c! + 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE ) +; + + +\ ------------------------------------------------------------------------- +\ To reset a valid port of a hub with a valid USB +\ address +\ -------------------------------------------------------------------------- + + +: control-hub-port-reset-set ( port# -- TRUE|FALSE ) + hprst-set setup-packet ! ( port# ) + setup-packet 4 + c! + 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE ) +; + + +\ ------------------------------------------------------------------------- +\ To enable a particular valid port of a hub with a valid USB address +\ ------------------------------------------------------------------------- + + +: control-hub-port-enable ( port# -- TRUE|FALSE ) + hpena-set setup-packet ! ( port# ) + setup-packet 4 + c! + 0 0 0 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE ) +; + + +\ ------------------------------------------------------------------------- +\ To get the status of a valid port of a hub with +\ a valid USB address +\ ------------------------------------------------------------------------- + + +: control-hub-port-status-get ( buffer port# -- TRUE|FALSE ) + hpsta-get setup-packet ! ( buffer port# ) + setup-packet 4 + c! ( buffer ) + 0 swap 4 setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE ) +; + + +\ -------------------------------------------------------------------------- +\ To get the hub descriptor to understand how many ports are vailable and the +\ specs of those ports +\ --------------------------------------------------------------------------- + + +: control-get-hub-descriptor ( buffer buffer-length -- TRUE|FALSE ) + hubds-get setup-packet ! + dup setup-packet 6 + w!-le ( buffer buffer-length ) + 0 -rot setup-packet MPS-DCP my-usb-address controlxfer ( TRUE|FALSE ) +; + + +s" usb-enumerate.fs" INCLUDED + + +: hub-configure-port ( port# -- ) + +\ this port has been powered on +\ send reset to enable port and +\ start device detection by hub +\ some devices require a long timeout here (10s) + + \ Step 1: check if reset state ended + + BEGIN ( port# ) + status-buffer 4 erase ( port# ) + status-buffer over control-hub-port-status-get drop ( port# ) + status-buffer w@-le 102 and 0= ( port# TRUE|FALSE ) + WHILE ( port# ) + REPEAT ( port# ) + po2pg 3 * ms \ wait for bPwrOn2PwrGood*3 ms + + \ STEP 2: Reset the port. + \ (this also enables the port) + dup control-hub-port-reset-set drop ( port# ) + BEGIN ( port# ) + status-buffer 4 erase ( port# ) + status-buffer over control-hub-port-status-get drop ( port# ) + status-buffer w@-le 10 and ( port# TRUE|FALSE ) + WHILE ( port# ) + REPEAT ( port# ) + + \ STEP 3: Check if a device is connected to the port. + + status-buffer 4 erase ( port# ) + status-buffer over control-hub-port-status-get drop ( port# ) + status-buffer w@-le 103 and 103 <> ( port# TRUE|FALSE ) + s" Port status bits: " status-buffer w@-le usb-debug-print-val + IF ( port# ) + drop + s" Connect status: No device connected " usb-debug-print + EXIT + THEN + + + \ STEP 4: Assign an address to this device. + + status-buffer w@-le 200 and 4 lshift \ get speed bit + dup to device-speed \ store speed bit + ( port# speedbit ) + control-std-set-address ( port# usb-addr TRUE|FALSE ) + 50 ms ( port# usb-addr TRUE|FALSE ) + debug-td ( port# usb-addr TRUE|FALSE ) + IF ( port# usb-addr ) + device-speed or ( port# usb-addr+speedbit ) + to new-device-address ( port# ) + to port-number + dd-buffer @ DEVICE-DESCRIPTOR-LEN erase + dd-buffer @ DEFAULT-CONTROL-MPS DEFAULT-CONTROL-MPS new-device-address + ( buffer mps mps usb-addr ) + control-std-get-device-descriptor ( TRUE|FALSE ) + IF + dd-buffer @ DEVICE-DESCRIPTOR-TYPE-OFFSET + c@ ( descriptor-type ) + DEVICE-DESCRIPTOR-TYPE <> ( TRUE|FALSE ) + IF + s" HUB: ERROR!! Invalid Device Descriptor for the new device" + usb-debug-print + ELSE + dd-buffer @ DEVICE-DESCRIPTOR-MPS-OFFSET + c@ to mps + + \ Re-read the device descriptor again with the known MPS. + + dd-buffer @ DEVICE-DESCRIPTOR-LEN erase + dd-buffer @ DEVICE-DESCRIPTOR-LEN mps new-device-address + ( buffer descp-len mps usb-addr ) + \ s" DEVICE DESCRIPTOR: " usb-debug-print + control-std-get-device-descriptor invert + IF + s" ** reading dev-descriptor failed ** " usb-debug-print + THEN + create-usb-device-tree + THEN + ELSE + s" ERROR!! Failed to get device descriptor" usb-debug-print + THEN + ELSE ( port# ) + s" USB Set Adddress failed!!" usb-debug-print ( port# ) + s" Clearing Port Power..." usb-debug-print ( port# ) + control-hub-port-power-clear ( TRUE|FALSE ) + IF + s" Port power down " usb-debug-print + ELSE + s" Unable to clear port power!!!" usb-debug-print + THEN + THEN +; + + +\ --------------------------------------------------------------------------- +\ To enumerate all the valid ports of hub +\ TODO: +\ 1. Remove hardcoded constants. +\ 2. Remove Endian Dependencies. +\ 3. Return values of controlxfer should be checked. +\ --------------------------------------------------------------------------- + +: hub-enumerate ( -- ) + cd-buffer @ CONFIG-DESCRIPTOR-LEN erase + + \ Get HUB configuration and SET the configuration + \ note: remove hard-coded constants. + + cd-buffer @ CONFIG-DESCRIPTOR-LEN MPS-DCP my-usb-address + ( buffer descp-len mps usb-address ) + control-std-get-configuration-descriptor drop + cd-buffer @ 1+ c@ 2 <> IF + s" Unable to read configuration descriptor" usb-debug-print + EXIT + THEN + cd-buffer @ 4 + c@ 1 <> IF + s" Not a valid HUB config descriptor" usb-debug-print + EXIT + THEN + + \ TODO: Do further checkings on the returned Configuration descriptor + \ before proceeding to accept it. + + cd-buffer @ 5 + c@ to temp1 \ Store the configuration in temp1 + temp1 my-usb-address control-std-set-configuration drop + my-usb-address to temp1 + hd-buffer 9 erase + hd-buffer 9 control-get-hub-descriptor drop + + \ PENDING: 1. Check Return value. + \ 2. HUB descriptor size is variable. Currently we r hardcoding + \ a value of 9. + + hd-buffer 2 + c@ to temp2 \ number of downstream ports + + s" HUB: Found " usb-debug-print + s" number of downstream hub ports! : " temp2 usb-debug-print-val + hd-buffer 5 + c@ to po2pg \ get bPwrOn2PwrGood + + \ power on all present hub ports + \ to allow slow devices to set up + + temp2 1+ 1 DO + i control-hub-port-power-set drop + d# 20 ms + LOOP + + d# 200 ms \ some devices need a long time (10s) + + \ now start detection and configuration for these ports + + temp2 1+ 1 DO + s" hub-configure-port: " i usb-debug-print-val + i hub-configure-port + LOOP +; + + +\ -------------------------------------------------------------------------- +\ To initialize hub +\ -------------------------------------------------------------------------- + +(allocate-mem) +mps-property-set +hub-enumerate +(de-allocate-mem) + diff --git a/slof/fs/usb/usb-kbd-device-support.fs b/slof/fs/usb/usb-kbd-device-support.fs new file mode 100644 index 0000000..9fa4236 --- /dev/null +++ b/slof/fs/usb/usb-kbd-device-support.fs @@ -0,0 +1,102 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +00 value kbd-addr +to kbd-addr +8 alloc-mem to kbd-report +4 chars alloc-mem value kbd-data + +: rw-endpoint + s" rw-endpoint" $call-parent ; + +: controlxfer + s" controlxfer" $call-parent ; + +: control-std-get-device-descriptor + s" control-std-get-device-descriptor" $call-parent ; + +: control-std-get-configuration-descriptor + s" control-std-get-configuration-descriptor" $call-parent ; + +: control-std-set-configuration + s" control-std-set-configuration" $call-parent ; + +: control-cls-set-protocol ( reportvalue FuncAddr -- TRUE|FALSE ) + to temp1 + to temp2 + 210b000000000100 setup-packet ! + temp2 kbd-data l!-le + 1 kbd-data 1 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer +; + +: control-cls-set-idle ( reportvalue FuncAddr -- TRUE|FALSE ) + to temp1 + to temp2 + 210a000000000000 setup-packet ! + temp2 kbd-data l!-le + 0 kbd-data 0 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer +; + +: control-std-get-report-descriptor ( data-buffer data-len MPS FuncAddr -- TRUE|FALSE ) + to temp1 + to temp2 + to temp3 + 8106002200000000 setup-packet ! + temp3 setup-packet 6 + w!-le + 0 swap temp3 setup-packet temp2 temp1 controlxfer +; + +: kbd-init + s" Starting to initialize keyboard" usb-debug-print + s" MPS-INTIN" get-my-property + if + s" not possible" usb-debug-print + else + decode-int nip nip to mps-int-in + then + s" INT-IN-EP-ADDR" get-my-property + if + s" not possible" usb-debug-print + else + decode-int nip nip to int-in-ep + then + + 7f alloc-mem to cfg-buffer + s" Allocated buffers!!" usb-debug-print + + cfg-buffer 12 8 kbd-addr \ get device descriptor + control-std-get-device-descriptor + drop + \ s" dev_desc=" type cfg-buffer 12 dump cr + + cfg-buffer 9 8 kbd-addr \ get config descriptor + control-std-get-configuration-descriptor + drop + \ s" cfg_desc=" type cfg-buffer 9 dump cr + + cfg-buffer 5 + c@ kbd-addr \ set configuration + control-std-set-configuration + drop + s" KBDS: Set config returned" usb-debug-print + + 0 kbd-addr control-cls-set-idle drop \ set idle + s" KBDS: Set idle returned" usb-debug-print + + cfg-buffer 40 8 kbd-addr \ get report descriptor + control-std-get-report-descriptor + drop + \ s" report_desc=" type cfg-buffer 40 dump cr + + s" Finished initializing keyboard" usb-debug-print +; + diff --git a/slof/fs/usb/usb-keyboard.fs b/slof/fs/usb/usb-keyboard.fs new file mode 100644 index 0000000..fd96e6e --- /dev/null +++ b/slof/fs/usb/usb-keyboard.fs @@ -0,0 +1,371 @@ +\ ***************************************************************************** +\ * 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" keyboard" device-name +s" keyboard" device-type + +." USB Keyboard" cr + +3 encode-int s" assigned-addresses" property +1 encode-int s" reg" property +1 encode-int s" configuration#" property +s" EN" encode-string s" language" property + +1 constant NumLk +2 constant CapsLk +4 constant ScrLk + +00 value kbd-addr +to kbd-addr \ save speed bit +8 value mps-dcp +8 constant DEFAULT-CONTROL-MPS +8 chars alloc-mem value setup-packet +8 chars alloc-mem value kbd-report +4 chars alloc-mem value multi-key +0 value cfg-buffer +0 value led-state +0 value temp1 +0 value temp2 +0 value temp3 +0 value ret +0 value scancode +0 value kbd-shift +0 value kbd-scan +0 value key-old +0 value expire-ms +0 value mps-int-in +0 value int-in-ep +0 value int-in-toggle + +kbd-addr \ give speed bit to include file +s" usb-kbd-device-support.fs" included + +: control-cls-set-report ( reportvalue FuncAddr -- TRUE|FALSE ) + to temp1 + to temp2 + 2109000200000100 setup-packet ! + temp2 kbd-data l!-le + 1 kbd-data 1 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer +; + +: control-cls-get-report ( data-buffer data-len MPS FuncAddr -- TRUE|FALSE ) + to temp1 + to temp2 + to temp3 + a101000100000000 setup-packet ! + temp3 setup-packet 6 + w!-le + 0 swap temp3 setup-packet temp2 temp1 controlxfer +; + +: int-get-report ( -- ) \ get report for interrupt transfer + 0 2 int-in-toggle kbd-report 8 mps-int-in + kbd-addr int-in-ep 7 lshift or rw-endpoint \ get report + swap to int-in-toggle if + kbd-report @ ff00000000000000 and 38 rshift to kbd-shift \ store shift status + kbd-report @ 0000ffffffffffff and to kbd-scan \ store scan codes + else + 0 to kbd-shift \ clear shift status + 0 to kbd-scan \ clear scan code buffer + then +; + +: ctl-get-report ( -- ) \ get report for control transfer + kbd-report 8 8 kbd-addr control-cls-get-report if \ get report + kbd-report @ ff00000000000000 and 38 rshift to kbd-shift \ store shift status + kbd-report @ 0000ffffffffffff and to kbd-scan \ store scan codes + else + 0 to kbd-shift \ clear shift status + 0 to kbd-scan \ clear scan code buffer + then +; + +: set-led ( led -- ) + dup to led-state + kbd-addr control-cls-set-report drop +; + +: is-shift ( -- true|false ) + kbd-shift 22 and if + true + else + false + then +; + +: is-alt ( -- true|false ) + kbd-shift 44 and if + true + else + false + then +; + +: is-ctrl ( -- true|false ) + kbd-shift 11 and if + true + else + false + then +; + +: ctrl_alt_del_key ( char -- ) + is-ctrl if \ ctrl is pressed? + is-alt if \ alt is pressed? + 4c = if \ del is pressed? + s" reboot.... " usb-debug-print + \ reset-all \ reboot + drop false \ invalidate del key on top of stack + then + false \ dummy for last drop + then + then + drop \ clear stack +; + +: get-ukbd-char ( ScanCode -- char|false ) + dup ctrl_alt_del_key \ check ctrl+alt+del + dup to scancode \ store scan code + case \ translate scan code --> char + 04 of [char] a endof + 05 of [char] b endof + 06 of [char] c endof + 07 of [char] d endof + 08 of [char] e endof + 09 of [char] f endof + 0a of [char] g endof + 0b of [char] h endof + 0c of [char] i endof + 0d of [char] j endof + 0e of [char] k endof + 0f of [char] l endof + 10 of [char] m endof + 11 of [char] n endof + 12 of [char] o endof + 13 of [char] p endof + 14 of [char] q endof + 15 of [char] r endof + 16 of [char] s endof + 17 of [char] t endof + 18 of [char] u endof + 19 of [char] v endof + 1a of [char] w endof + 1b of [char] x endof + 1c of [char] y endof + 1d of [char] z endof + 1e of [char] 1 endof + 1f of [char] 2 endof + 20 of [char] 3 endof + 21 of [char] 4 endof + 22 of [char] 5 endof + 23 of [char] 6 endof + 24 of [char] 7 endof + 25 of [char] 8 endof + 26 of [char] 9 endof + 27 of [char] 0 endof + 28 of 0d endof \ Enter + 29 of 1b endof \ ESC + 2a of 08 endof \ Backsace + 2b of 09 endof \ Tab + 2c of 20 endof \ Space + 2d of [char] - endof + 2e of [char] = endof + 2f of [char] [ endof + 30 of [char] ] endof + 31 of [char] \ endof + 33 of [char] ; endof + 34 of [char] ' endof + 35 of [char] ` endof + 36 of [char] , endof + 37 of [char] . endof + 38 of [char] / endof + 39 of led-state CapsLk xor set-led false endof \ CapsLk + 3a of 1b 7e31315b to multi-key endof \ F1 + 3b of 1b 7e32315b to multi-key endof \ F2 + 3c of 1b 7e33315b to multi-key endof \ F3 + 3d of 1b 7e34315b to multi-key endof \ F4 + 3e of 1b 7e35315b to multi-key endof \ F5 + 3f of 1b 7e37315b to multi-key endof \ F6 + 40 of 1b 7e38315b to multi-key endof \ F7 + 41 of 1b 7e39315b to multi-key endof \ F8 + 42 of 1b 7e30315b to multi-key endof \ F9 + 43 of 1b 7e31315b to multi-key endof \ F10 + 44 of 1b 7e33315b to multi-key endof \ F11 + 45 of 1b 7e34315b to multi-key endof \ F12 + 47 of led-state ScrLk xor set-led false endof \ ScrLk + 49 of 1b 7e315b to multi-key endof \ Ins + 4a of 1b 7e325b to multi-key endof \ Home + 4b of 1b 7e335b to multi-key endof \ PgUp + 4c of 1b 7e345b to multi-key endof \ Del + 4d of 1b 7e355b to multi-key endof \ End + 4e of 1b 7e365b to multi-key endof \ PgDn + 4f of 1b 435b to multi-key endof \ R-arrow + 50 of 1b 445b to multi-key endof \ L-arrow + 51 of 1b 425b to multi-key endof \ D-arrow + 52 of 1b 415b to multi-key endof \ U-arrow + 53 of led-state NumLk xor set-led false endof \ NumLk + 54 of [char] / endof \ keypad / + 55 of [char] * endof \ keypad * + 56 of [char] - endof \ keypad - + 57 of [char] + endof \ keypad + + 58 of 0d endof \ keypad Enter + 89 of [char] \ endof \ japanese yen + dup of false endof \ other keys are false + endcase + to ret \ store char + led-state CapsLk and 0 <> if \ if CapsLk is on + scancode 03 > if \ from a to z ? + scancode 1e < if + ret 20 - to ret \ to Upper case + then + then + then + is-shift if \ if shift is on + scancode 03 > if \ from a to z ? + scancode 1e < if + ret 20 - to ret \ to Upper case + else + scancode + case \ translate scan code --> char + 1e of [char] ! endof + 1f of [char] @ endof + 20 of [char] # endof + 21 of [char] $ endof + 22 of [char] % endof + 23 of [char] ^ endof + 24 of [char] & endof + 25 of [char] * endof + 26 of [char] ( endof + 27 of [char] ) endof + 2d of [char] _ endof + 2e of [char] + endof + 2f of [char] { endof + 30 of [char] } endof + 31 of [char] | endof + 33 of [char] : endof + 34 of [char] " endof + 35 of [char] ~ endof + 36 of [char] < endof + 37 of [char] > endof + 38 of [char] ? endof + dup of ret endof \ other keys are no change + endcase + to ret \ overwrite new char + then + then + then + led-state NumLk and 0 <> if \ if NumLk is on + scancode + case \ translate scan code --> char + 59 of [char] 1 endof + 5a of [char] 2 endof + 5b of [char] 3 endof + 5c of [char] 4 endof + 5d of [char] 5 endof + 5e of [char] 6 endof + 5f of [char] 7 endof + 60 of [char] 8 endof + 61 of [char] 9 endof + 62 of [char] 0 endof + 63 of [char] . endof \ keypad . + dup of ret endof \ other keys are no change + endcase + to ret \ overwirte new char + then + ret \ return char +; + +: key-available? ( -- true|false ) + multi-key 0 <> IF + true \ multi scan code key was pressed... so key is available + EXIT \ done + THEN + kbd-scan 0 = IF \ if no kbd-scan code is currently available + int-get-report \ check for one using int-get-report + THEN + kbd-scan 0 <> \ if a kbd-scan is available, report true, else false +; + +: usb-kread ( -- char|false ) \ usb key read for control transfer + multi-key 0 <> if \ if multi scan code key is pressed + multi-key ff and \ read one byte from buffer + multi-key 8 rshift to multi-key \ move to next byte + else \ normal key check + \ check for new scan code only, if kbd-scan is not set, e.g. + \ by a previous call to key-available? + kbd-scan 0 = IF + \ if interrupt transfer + int-get-report \ read report (interrupt transfer) + \ else control transfer + \ ctl-get-report \ read report (control transfer) + \ end of interrupt/control switch + THEN + kbd-scan 0 <> if \ scan code exist? + begin kbd-scan ff and dup 00 = while \ get a last scancode in report buffer + kbd-scan 8 rshift to kbd-scan \ This algorithm is wrong --> must be fixed! + drop \ KBD doesn't set scancode in pressed order!!! + repeat + dup key-old <> if \ if the scancode is new + dup to key-old \ save current scan code + get-ukbd-char \ translate scan code --> char + milliseconds fa + to expire-ms \ set typematic delay 250ms + else \ scan code is not changed + milliseconds expire-ms > if \ if timer is expired ... should be considered timer carry over + get-ukbd-char \ translate scan code --> char + milliseconds 21 + to expire-ms \ set typematic rate 30cps + else \ timer is not expired + drop false \ do nothing + then + then + kbd-scan 8 rshift to kbd-scan \ handled scan-code + else + 0 to key-old \ clear privious key + false \ no scan code --> return false + then + then +; + + +: key-read ( -- char ) + 0 begin drop usb-kread dup 0 <> until \ read key input (Interrupt transfer) +; + + +: read ( addr len -- actual ) + 0= IF drop 0 EXIT THEN + usb-kread ?dup IF swap c! 1 ELSE 0 swap c! -2 THEN +; + + +kbd-init \ keyboard initialize +milliseconds to expire-ms \ Timer initialize +0 to multi-key \ multi key buffer clear +7 set-led \ flash leds +250 ms +0 set-led + +s" keyboard" get-node node>path set-alias + +: open ( -- true ) + 7 set-led + 100 ms + 3 set-led + 100 ms + 1 set-led + 100 ms + \ read once from keyboard before actually using it + usb-kread drop + 0 set-led + true +; + +: close ; diff --git a/slof/fs/usb/usb-mouse.fs b/slof/fs/usb/usb-mouse.fs new file mode 100644 index 0000000..bd6fa50 --- /dev/null +++ b/slof/fs/usb/usb-mouse.fs @@ -0,0 +1,28 @@ +\ ***************************************************************************** +\ * 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" mouse" device-name +s" mouse" device-type + +." USB Mouse" cr + +1 encode-int s" configuration#" property +2 encode-int s" #buttons" property +4 encode-int s" assigned-addresses" property +2 encode-int s" reg" property + +: open true ; +: close ; +: get-event ( msec -- pos.x pos.y buttons true|false ) +; + diff --git a/slof/fs/usb/usb-ohci.fs b/slof/fs/usb/usb-ohci.fs new file mode 100644 index 0000000..f4d9670 --- /dev/null +++ b/slof/fs/usb/usb-ohci.fs @@ -0,0 +1,1190 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ We expect to base address of the OHCI controller on the stack: + +CONSTANT baseaddrs + +s" OHCI base address = " baseaddrs usb-debug-print-val + + +\ Open Firmware Properties + + +s" usb" 2dup device-name device-type +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 ; + + +\ Data Structure Definitions +\ OHCI Task Descriptor Structure. + + +STRUCT + /l field td>tattr + /l field td>cbptr + /l field td>ntd + /l field td>bfrend +CONSTANT /tdlen + + +\ OHCI Endpoint Descriptor Structure. + + +STRUCT + /l field ed>eattr + /l field ed>tdqtp + /l field ed>tdqhp + /l field ed>ned +CONSTANT /edlen + + +\ HCCA Done queue location packaged as a structure for ease OF use. + + +STRUCT + /l field hc>hcattr + /l field hc>hcdone +CONSTANT /hclen + + +\ OHCI Memory Mapped Registers + + +\ : get-base-address ( -- baseaddr ) +\ s" assigned-addresses" get-my-property IF +\ s" not possible" usb-debug-print +\ -1 +\ ELSE ( addr len ) +\ decode-int drop ( addr len ) +\ decode-int drop ( addr len ) +\ decode-int nip nip ( n ) +\ THEN +\ \ TODO: Use translate-address here +\ ; + +\ get-base-address CONSTANT baseaddrs + +baseaddrs CONSTANT HcRevision +baseaddrs 4 + CONSTANT hccontrol +baseaddrs 8 + CONSTANT hccomstat +baseaddrs 0c + CONSTANT hcintstat +baseaddrs 14 + CONSTANT hcintdsbl +baseaddrs 18 + CONSTANT hchccareg +baseaddrs 20 + CONSTANT hcctrhead +baseaddrs 24 + CONSTANT hccurcont +baseaddrs 28 + CONSTANT hcbulkhead +baseaddrs 2c + CONSTANT hccurbulk +baseaddrs 30 + CONSTANT hcdnehead +baseaddrs 34 + CONSTANT hcintrval +baseaddrs 40 + CONSTANT HcPeriodicStart +baseaddrs 48 + CONSTANT hcrhdescA +baseaddrs 4c + CONSTANT hcrhdescB +baseaddrs 50 + CONSTANT HcRhStatus +baseaddrs 54 + CONSTANT hcrhpstat +baseaddrs 58 + CONSTANT hcrhpstat2 +baseaddrs 5c + CONSTANT hcrhpstat3 + +usb-debug-flag IF + 0 config-l@ ." - VENDOR: " 8 .r cr + 40 config-l@ ." - PMC : " 8 .r + 44 config-l@ ." PMCSR : " 8 .r cr + E0 config-l@ ." - EXT1 : " 8 .r + E4 config-l@ ." EXT2 : " 8 .r cr +THEN + +\ Constants for INTSTAT register + +2 CONSTANT WDH + +\ Constants for RH Port Status Register + +1 CONSTANT RHP-CCS \ Current Connect Status +2 CONSTANT RHP-PES \ Port Enable Status +10 CONSTANT RHP-PRS \ Port Reset Status +100 CONSTANT RHP-PPS \ Port Power Status +10000 CONSTANT RHP-CSC \ Connect Status Changed +100000 CONSTANT RHP-PRSC \ Port Reset Status Changed + + +\ Constants for OHCI + +0 CONSTANT OHCI-DP-SETUP +1 CONSTANT OHCI-DP-OUT +2 CONSTANT OHCI-DP-IN +3 CONSTANT OHCI-DP-INVALID + +\ 8-byte Standard Device Requests + Hub class specific requests. + +8006000100001200 CONSTANT get-ddescp +8006000200000900 CONSTANT get-cdescp +8006000400000900 CONSTANT get-idescp +8006000500000700 CONSTANT get-edescp +A006000000001000 CONSTANT get-hdescp +0009010000000000 CONSTANT set-cdescp +2303010004000000 CONSTANT hpenable-set +2303040001000000 CONSTANT hp1rst-set +2303040002000000 CONSTANT hp2rst-set +2303040003000000 CONSTANT hp3rst-set +2303040004000000 CONSTANT hp4rst-set +2303080001000000 CONSTANT hp1pwr-set +2303080002000000 CONSTANT hp2pwr-set +2303080003000000 CONSTANT hp3pwr-set +2303080004000000 CONSTANT hp4pwr-set +A003000000000400 CONSTANT hstatus-get +A300000001000400 CONSTANT hp1sta-get +A300000002000400 CONSTANT hp2sta-get +A300000003000400 CONSTANT hp3sta-get +A300000004000400 CONSTANT hp4sta-get +8008000000000100 CONSTANT get-config + +A1FE000000000100 CONSTANT GET-MAX-LUN + +2 18 lshift CONSTANT DATA0-TOGGLE +3 18 lshift CONSTANT DATA1-TOGGLE +0f 1c lshift CONSTANT CC-FRESH-TD +8 CONSTANT STD-REQUEST-SETUP-SIZE +0 13 lshift CONSTANT TD-DP-SETUP +1 13 lshift CONSTANT TD-DP-OUT +2 13 lshift CONSTANT TD-DP-IN + +400001 CONSTANT ed-cntatr +400002 CONSTANT ed-cntatr1 +80081 CONSTANT ed-hubatr +80000 CONSTANT ed-defatr +0f0e40000 CONSTANT td-attr +00 VALUE ptr + + +\ TD Management constants and Data structures. + + +200 CONSTANT MAX-TDS +0 VALUE td-freelist-head +0 VALUE td-freelist-tail +0 VALUE num-free-tds +0 VALUE max-rh-ports +0 VALUE current-stat + +INSTANCE VARIABLE td-list-region + +\ ED Management constants + + +14 CONSTANT MAX-EDS +0 VALUE ed-freelist-head +0 VALUE num-free-eds +INSTANCE VARIABLE ed-list-region +0 VALUE usb-address +0 VALUE initial-hub-address +0 VALUE new-device-address +0 VALUE mps +0 VALUE DEBUG-TDS +0 VALUE case-failed \ available for general use to see IF a CASE statement + \ failed or not. +0 VALUE WHILE-failed \ available for general use to see IF a WHILE LOOP + \ failed in the middle. Used to break from the + \ WHILE LOOP + +8 CONSTANT DEFAULT-CONTROL-MPS +12 CONSTANT DEVICE-DESCRIPTOR-LEN +1 CONSTANT DEVICE-DESCRIPTOR-TYPE +1 CONSTANT DEVICE-DESCRIPTOR-TYPE-OFFSET +4 CONSTANT DEVICE-DESCRIPTOR-DEVCLASS-OFFSET +7 CONSTANT DEVICE-DESCRIPTOR-MPS-OFFSET + +20 CONSTANT BULK-CONFIG-DESCRIPTOR-LEN + +9 CONSTANT HUB-DEVICE-CLASS +0 CONSTANT NO-CLASS + +VARIABLE setup-packet \ 8 bytes for setup packet +VARIABLE ch-buffer \ 1 byte character buffer + +INSTANCE VARIABLE dd-buffer +INSTANCE VARIABLE cd-buffer + + +\ Temporary variables for functions. These variables have to be initialized +\ before usage in functions and their values assume significance only during +\ the function's execution time. Should be used like local variables. +\ CAUTION: +\ If you are calling functions that destroy contents OF these variables, be +\ smart enuf to save the values before calling them. +\ It is recommended that these temporary variables are used only amidst normal +\ FORTH words -- not among the vicinity OF any OF the functions OF this node. + + +0 VALUE temp1 +0 VALUE temp2 +0 VALUE temp3 +0 VALUE extra-bytes +0 VALUE num-td +0 VALUE current + +0 VALUE device-speed + + +\ Debug functions for displaying ED, TD and their combo list. + +: Show-OHCI-Register + ." -> OHCI-Register: " cr + ." - HcControl : " hccontrol rl@-le 8 .r + ." CmdStat : " hccomstat rl@-le 8 .r + ." HcInterr. : " hcintstat rl@-le 8 .r cr + + ." - HcFmIntval: " hcintrval rl@-le 8 .r + ." Per. Start: " HcPeriodicStart rl@-le 8 .r cr + + ." - PortStat-1: " hcrhpstat rl@-le 8 .r + ." PortStat-2: " hcrhpstat2 rl@-le 8 .r + ." PortStat-3: " hcrhpstat3 rl@-le 8 .r cr + + ." Descr-A : " hcrhdescA rl@-le 8 .r + ." Descr-B : " hcrhdescB rl@-le 8 .r + ." HcRhStat : " HcRhStatus rl@-le 8 .r cr +; + +: display-ed ( ED-ADDRESS -- ) + TO temp1 + usb-debug-flag IF + s" Dump OF ED " type temp1 u. cr + s" eattr : " type temp1 ed>eattr l@-le u. cr + s" tdqhp : " type temp1 ed>tdqhp l@-le u. cr + s" tdqtp : " type temp1 ed>tdqtp l@-le u. cr + s" ned : " type temp1 ed>ned l@-le u. cr + THEN +; + + +\ Displays the transfer descriptors + +: display-td ( TD-ADDRESS -- ) + TO temp1 + usb-debug-flag IF + s" TD " type temp1 u. s" dump: " type cr + s" td>tattr : " type temp1 td>tattr l@-le u. cr + s" td>cbptr : " type temp1 td>cbptr l@-le u. cr + s" td>ntd : " type temp1 td>ntd l@-le u. cr + s" td>bfrend : " type temp1 td>bfrend l@-le u. cr + THEN +; + + +\ display's the descriptors + + +: display-descriptors ( ED-ADDRESS -- ) + 10 1- not and ( ED-ADDRESS~ ) + dup display-ed ed>tdqhp l@-le BEGIN ( ED-ADDRESS~ ) + 10 1- not and ( ED-ADDRESS~ ) + dup 0<> ( ED-ADDRESS~ TRUE | FALSE ) + WHILE + dup display-td td>ntd l@-le ( ED-ADDRESS~ ) + REPEAT + drop +; + + +\ --------------------------------------------------------------------------- +\ TD LIST MANAGEMENT WORDS +\ ------------------------ +\ The following are WORDS internal to this node. They are supposed to +\ be used by other WORDS inside this device node. +\ The first three WORDS below form the interface. The fourth and fifth +\ word is a helper function and is not exposed to other portions OF this +\ device node. +\ a) initialize-td-free-list +\ b) allocate-td-list +\ c) (free-td-list) +\ d) find-td-list-tail-and-size +\ e) zero-out-a-td-except-link +\ ---------------------------------------------------------------------------- + + +: zero-out-a-td-except-link ( td -- ) + + + \ There r definitely smarter ways to DO it especially + \ on a 64-bit machine. + + \ Optimization, Portability: + \ -------------------------- + \ Replace the following code by two "!" OF zeroes. Since + \ we know that an "td" is actually 16 bytes and that we + \ will be executing on a 64-bit machine, we can finish OFf + \ with 2 stores. But that WONT be portable. + + + dup 0 swap td>tattr l!-le ( td ) + dup 0 swap td>cbptr l!-le ( td ) + dup 0 swap td>bfrend l!-le ( td ) + drop +; + + +\ COLON DEFINITION: initialize-td-free-list - Internal Function + +\ Initialize the TD Free List Region and create a linked list OF successive +\ TDs. Note that the NEXT pointers are all in little-endian and they +\ can be directly used for HC purposes. + + +: initialize-td-free-list ( -- ) + MAX-TDS 0= IF EXIT THEN + td-list-region @ 0= IF EXIT THEN + td-list-region @ TO temp1 + 0 TO temp2 BEGIN + temp1 zero-out-a-td-except-link + temp1 /tdlen + dup temp1 td>ntd l!-le TO temp1 + temp2 1+ TO temp2 + temp2 MAX-TDS = ( TRUE | FALSE ) + UNTIL + temp1 /tdlen - dup 0 swap td>ntd l!-le TO td-freelist-tail + td-list-region @ TO td-freelist-head + MAX-TDS TO num-free-tds +; + + +\ COLON DEFINITION: allocate-td-list -- Internal function +\ Argument: +\ The function accepts a non-negative number and allocates +\ a TD-LIST containing that many TDs. A TD-LIST is a list +\ OF TDs that are linked by the next-td field. The next-td +\ field is in little-endian mode so that the TD list can +\ be directly re-used by the HC. +\ Return value: +\ The function returns "head" and "tail" OF the allocated +\ TD-LIST. If for any reason, the function cannot allocate +\ the TD-LIST, the function returns 2 NULL pointers in the +\ stack indicating that the allocation failed. + +\ Note that the TD list returned is NULL terminated. i.e +\ the nextTd field OF the tail is NULL. + + + +: allocate-td-list ( n -- head tail ) + dup 0= IF drop 0 0 EXIT THEN ( 0 0 ) + dup num-free-tds > IF drop 0 0 EXIT THEN ( 0 0 ) + dup num-free-tds = IF ( n ) + drop td-freelist-head td-freelist-tail ( td-freelist-head td-freelist-tail ) + 0 TO td-freelist-head ( td-freelist-head td-freelist-tail ) + 0 TO td-freelist-tail ( td-freelist-head td-freelist-tail ) + 0 TO num-free-tds ( td-freelist-head td-freelist-tail ) + EXIT + THEN + + \ If we are here THEN we know that the requested number OF TDs is less + \ than what we actually have. We need TO traverse the list and find the + \ new Head pointer position and THEN update the head pointer accordingly. + \ Update num-free-tds + + dup num-free-tds swap - TO num-free-tds ( n ) + + \ Traverse through the Free list to identify the element that exists after + \ "n" TDs. Use the info to return the head and tail pointer and update + \ the new td-list-head + + td-freelist-head ( n td-list-head ) + dup TO temp1 ( n td-list-head ) + swap ( td-list-head n ) + 0 DO ( td-list-head ) + temp1 TO temp2 ( td-list-head ) + temp1 td>ntd l@-le TO temp1 ( td-list-head ) + LOOP ( td-list-head ) + temp2 ( td-list-head td-list-tail ) + dup td>ntd 0 swap l!-le ( td-list-head td-list-tail ) + temp1 TO td-freelist-head ( td-list-head td-list-tail ) +; + + +\ COLON DEFINITION: find-td-list-tail-and-size +\ This function counts the number OF TD elements +\ in the given list. It also returns the last tail +\ TD OF the TD list. + +\ ASSUMPTION: +\ A NULL terminated TD list is assumed. A not-well formed +\ list can result in in-determinate behaviour. + +\ ROOM FOR ENHANCEMENT: +\ We could arrive at a generic function for counting +\ list elements to which the next-ptr OFfset can also +\ be passed as an argument (in this case it is >ntd) +\ This function can THEN be changed to call the +\ function with "0 >ntd" as an additional argument +\ (apart from head and tail) + + +: find-td-list-tail-and-size ( head -- tail n ) + TO temp1 + 0 TO temp2 + 0 TO temp3 + DEBUG-TDS IF + s" BEGIN find-td-list-tail-and-size: " usb-debug-print + THEN + BEGIN + temp1 0<> ( TRUE|FALSE ) + WHILE + DEBUG-TDS IF + temp1 u. cr + THEN + temp1 TO temp3 + temp1 td>ntd l@-le TO temp1 + temp2 1+ TO temp2 + REPEAT + temp3 temp2 ( tail n ) + DEBUG-TDS IF + s" END find-td-list-tail-and-size" usb-debug-print + THEN +; + + +\ COLON DEFINITION: (free-td-list) + +\ Arguments: (head --) +\ The "head" pointer OF the TD-LIST to be freed is passed as +\ an argument to this function. The function merely adds the list to the +\ already existing TD-LIST + +\ Assumptions: +\ The function assumes that the TD-LIST passed as argument is a well-formed +\ list. The function does not DO any check on it. +\ But since, the "TD-LIST" is generally freed from the DONE-QUEUE which is +\ a well-formed list, the interface makes much sense. + +\ Return values: +\ Nothing is returned. The arguments passed are popped OFf. + + +: (free-td-list) ( head -- ) + + \ Enhancement: + \ We could zero-out-a-td-except-link for the TD list that is being freed. + \ This way, we could prevent some nasty repercussions OF bugs (that r yet + \ to be discovered). but we can include this enhancement during the testing + \ phase. + + dup find-td-list-tail-and-size num-free-tds + TO num-free-tds ( head tail ) + td-freelist-tail 0= IF ( head tail ) + dup TO td-freelist-tail ( head tail ) + THEN ( head tail ) + td>ntd td-freelist-head swap l!-le ( head ) + TO td-freelist-head +; + + +\ END OF TD LIST MANAGEMENT WORDS +\ ED Management section BEGINs +\ ---------------------------- + + +: zero-out-an-ed-except-link ( ed -- ) + + \ There are definitely smarter ways to do it especially + \ on a 64-bit machine. + + \ Optimization, Portability: + \ -------------------------- + \ Replace by a "!" and "l!". we know that an "ed" is + \ actually 16 bytes and that we will be executing on + \ a 64-bit machine, we can finish OFf with 2 stores. + \ But that WONT be portable. + + dup 0 swap ed>eattr l!-le ( ed ) + dup 0 swap ed>tdqtp l!-le ( ed ) + dup 0 swap ed>tdqhp l!-le ( ed ) + drop +; + +\ Intialises ed-list afresh + +: initialize-ed-free-list ( -- ) + MAX-EDS 0= IF EXIT THEN + ed-list-region @ 0= IF + s" init-ed-list: ed-list-region is not allocated!" usb-debug-print + EXIT + THEN + ed-list-region @ TO temp1 + 0 TO temp2 BEGIN + temp1 zero-out-an-ed-except-link + temp1 /edlen + dup temp1 ed>ned l!-le TO temp1 + temp2 1+ TO temp2 + temp2 MAX-EDS = + UNTIL + temp1 /edlen - ed>ned 0 swap l!-le + ed-list-region @ TO ed-freelist-head + MAX-EDS TO num-free-eds +; + + +\ allocate an ed and return ed address + + +: allocate-ed ( -- ed-ptr ) + num-free-eds 0= IF 0 EXIT THEN + ed-freelist-head ( ed-freelist-head ) + ed-freelist-head ed>ned l@-le TO ed-freelist-head ( ed-freelist-head ) + num-free-eds 1- TO num-free-eds ( ed-freelist-head ) + dup ed>ned 0 swap l!-le \ Terminate the Link. ( ed-freelist-head ) +; + + +\ free the given ed pointer + +: free-ed ( ed-ptr -- ) + dup zero-out-an-ed-except-link ( ed-ptr ) + dup ed>ned ed-freelist-head swap l!-le ( ed-ptr ) + TO ed-freelist-head + num-free-eds 1+ TO num-free-eds +; + + +\ Buffer allocations +\ ------------------ +\ Note: +\ ----- +\ 1. What should we DO IF alloc-mem fails ? +\ 2. alloc-mem must return aligned memory addresses. +\ 3. alloc-mem must return DMAable memory! + +\ Memory for the HCCA - must stay allocated as long as the HC is operational! +100 alloc-mem VALUE hchcca +hchcca ff and IF + \ This should never happen - alloc-mem always aligns + s" Warning: hchcca not aligned!" usb-debug-print +THEN + +84 hchcca + CONSTANT hchccadneq + + +: (allocate-mem) ( -- ) + /tdlen MAX-TDS * 10 + alloc-mem dup td-list-region ! ( td-list-region-ptr ) + f and IF + s" Warning: td-list-region not aligned!" usb-debug-print + THEN + initialize-td-free-list + + /edlen MAX-EDS * 10 + alloc-mem dup ed-list-region ! ( ed-list-region-ptr ) + f and IF + s" Warning: ed-list-region not aligned!" usb-debug-print + THEN + initialize-ed-free-list + + DEVICE-DESCRIPTOR-LEN chars alloc-mem dd-buffer ! + BULK-CONFIG-DESCRIPTOR-LEN chars alloc-mem cd-buffer ! +; + + +\ The method makes sure that when the host node is closed all +\ associated buffer allocations made for data-structures as +\ well as data-buffers are freed + +: (de-allocate-mem) ( -- ) + td-list-region @ ?dup IF + /tdlen MAX-TDS * 10 + free-mem + 0 td-list-region ! + THEN + ed-list-region @ ?dup IF + /edlen MAX-EDS * 10 + free-mem + 0 ed-list-region ! + THEN + dd-buffer @ ?dup IF + DEVICE-DESCRIPTOR-LEN free-mem + 0 dd-buffer ! + THEN + cd-buffer @ ?dup IF + BULK-CONFIG-DESCRIPTOR-LEN free-mem + 0 cd-buffer ! + THEN +; + + +\ Suspend hostcontroller (and the bus). +\ This method must be called before the operating system starts. +\ It prevents the HC from doing DMA in the background during boot +\ (e.g. updating its frame number counter in the HCCA) + +: hc-suspend ( -- ) + \ s" USB HC suspend with hccontrol=" type hccontrol . cr + 00C3 hccontrol rl!-le \ Suspend USB host controller +; + + +\ OF methods + +: open ( -- TRUE|FALSE ) + (allocate-mem) + TRUE +; + +: close ( -- ) + (de-allocate-mem) +; + + +\ COLON DEFINITION: HC-enable-control-list-processing +\ Enables USB HC transactions on control list. + +: HC-enable-control-list-processing ( -- ) + hccomstat dup rl@-le 02 or swap rl!-le + hccontrol dup rl@-le 10 or swap rl!-le +; + + +\ COLON DEFINTION: HC-enable-bulk-list-processing +\ PENDING: Remove Hard coded constants. + +: HC-enable-bulk-list-processing ( -- ) + hccomstat dup rl@-le 04 or swap rl!-le + hccontrol dup rl@-le 20 or swap rl!-le +; + + +: HC-enable-interrupt-list-processing ( -- ) + hccontrol dup rl@-le 04 or swap rl!-le +; + + +\ Clearing WDH to allow HC to write into DOne queue again + +: (HC-ACK-WDH) ( -- ) WDH hcintstat rl!-le ; + +\ Checking whether anything has been written into DOne queue + +: (HC-CHECK-WDH) ( -- ) hcintstat rl@-le WDH and 0<> ; + + +\ Disable USB transaction and keep it ready + +: disable-control-list-processing ( -- ) + hccontrol dup rl@-le ffffffef and swap rl!-le + hccomstat dup rl@-le fffffffd and swap rl!-le +; + +: disable-bulk-list-processing ( -- ) + hccontrol dup rl@-le ffffffdf and swap rl!-le + hccomstat dup rl@-le fffffffb and swap rl!-le +; + + +: disable-interrupt-list-processing ( -- ) + hccontrol dup rl@-le fffffffb and swap rl!-le +; + + +\ COLON DEFINITION: fill-TD-list + +\ This function accepts a TD list and a data-buffer and +\ distributes this data buffer over the TD list depending +\ on the Max Packet Size. + +\ Arguments: +\ ---------- +\ (from bottom OF stack) +\ 1. addr -- Address OF the data buffer +\ 2. dlen -- Length OF the data buffer above. +\ 3. dir -- Tells whether the TDs r for an IN or +\ OUT transaction. +\ 4. MPS -- Maximum Packet Size associated with the endpoint +\ that will use this TD list. +\ 5. TD-List-Head - Head pointer OF the List OF TDs. +\ This list is NOT expected to be NULL terminated. + +\ Assumptions: +\ ----------- +\ 1. TD-List for data is well-formed and has sufficient entries +\ to hold "dlen". +\ 2. The TDs toggle field is assumed to be taken from the endpoint +\ descriptor's "toggle carry" field. +\ 3. Assumes that the caller specifies the correct start-toggle. +\ If the caller specifies a wrong data toggle OF 1 for a SETUP +\ PACKET, this method will not find it out. + +\ COLON DEFINTION: (toggle-current-toggle) +\ Scope: Internal to fill-TD-list +\ Functionality: +\ Toggles the "T" field that is passed as argument. +\ "T" as in the "T" field OF the TD. + +0 VALUE current-toggle +: fill-TD-list ( start-toggle addr dlen dp MPS TD-List-Head -- ) + TO temp1 ( start-toggle addr dlen dp MPS ) + TO temp2 ( start-toggle addr dlen dp ) + CASE ( start-toggle addr dlen ) + OHCI-DP-SETUP OF TD-DP-SETUP TO temp3 ENDOF ( start-toggle addr dlen ) + OHCI-DP-IN OF TD-DP-IN TO temp3 ENDOF ( start-toggle addr dlen ) + OHCI-DP-OUT OF TD-DP-OUT TO temp3 ENDOF ( start-toggle addr dlen ) + dup OF -1 TO temp3 ( start-toggle addr dlen ) + s" fill-TD-list: Invalid DP specified" usb-debug-print + ENDOF + ENDCASE + temp3 -1 = IF EXIT THEN ( start-toggle addr dlen ) + + +\ temp1 -- TD-List-Head +\ temp2 -- Max Packet Size +\ temp3 -- TD-DP-IN or TD-DP-OUT or TD-DP-SETUP + + rot ( addr dlen start-toggle ) + TO current-toggle swap ( dlen addr ) + BEGIN + over temp2 >= ( dlen addr TRUE|FALSE ) + WHILE ( dlen addr ) + dup temp1 td>cbptr l!-le ( dlen addr ) + current-toggle 18 lshift ( dlen addr current-toggle~ ) + DATA0-TOGGLE ( dlen addr current-toggle~ toggle ) + CC-FRESH-TD temp3 or or or ( dlen addr or-result ) + temp1 td>tattr l!-le ( dlen addr~ ) + dup temp2 1- + temp1 td>bfrend l!-le ( dlen addr~ ) + temp2 + ( dlen next-addr ) + swap temp2 - swap + temp1 td>ntd l@-le TO temp1 ( dlen next-addr ) + current-toggle ( dlen next-addr current-toggle ) + CASE + 0 OF 1 TO current-toggle ENDOF + 1 OF 0 TO current-toggle ENDOF + ENDCASE + REPEAT ( dlen addr ) + over 0<> IF + dup temp1 td>cbptr l!-le ( dlen addr ) + current-toggle 18 lshift ( dlen addr curent-toggle~ ) + DATA0-TOGGLE ( dlen addr curent-toggle~ toggle ) + CC-FRESH-TD temp3 or or or ( dlen addr or-result ) + temp1 td>tattr l!-le ( dlen addr ) + + 1- temp1 td>bfrend l!-le + ELSE + 2drop + THEN +; + + +\ COLON DEFINITION: (td-list-status ) +\ FUNCTIONALITY: +\ To traverse the TD list to check for a TD carrying non-zero CC return the +\ respective TD address and CC ELSE 0 +\ SCOPE: +\ Internal method + +: (td-list-status) ( PointerToTDlist -- failingTD CCode TRUE | 0 ) + BEGIN ( PointerToTDlist ) + dup 0<> ( PointerToTDlist TRUE|FALSE ) + IF ( PointerToTDlist ) + dup td>tattr l@-le f0000000 and 1c rshift dup 0= TRUE swap + ( PointerToTDlist CCode TRUE TRUE|FALSE ) + ELSE + drop FALSE dup ( FALSE ) + THEN + WHILE + drop drop td>ntd l@-le + REPEAT +; + + +\ ================================================================== +\ COLON DEFINITION: (wait-for-done-q) +\ FUNCTIONALITY: +\ To DO a timed polling OF the DOne queue and acknowledge and return +\ the address OF the last retired Td list +\ SCOPE: +\ Internal method +\ ================================================================== + +: (wait-for-done-q) ( timeout -- TD-list TRUE | FALSE ) + BEGIN ( timeout ) + dup 0<> ( timeout TRUE|FALSE ) + (HC-CHECK-WDH) NOT ( timeout TRUE|FALSE TRUE|FALSE ) + AND \ not timed out AND WDH-bit not set + WHILE + 1 ms \ wait + 1- ( timeout ) + dup ff and 0= IF show-proceed THEN + REPEAT ( timeout ) + drop + hchccadneq l@-le \ read last HcDoneHead (RAM) + (HC-CHECK-WDH) \ HcDoneHead was updated ? + IF + (HC-ACK-WDH) \ clear register bit: WDH + TRUE ( td-list TRUE ) + ELSE + FALSE + THEN +; + + +\ displays free tds + + +: debug-td ( -- ) + s" Num Free TDs = " num-free-tds usb-debug-print-val +; + + +\ display content of frame counter + +\ : debug-frame-counter ( -- ) +\ 40 1 DO +\ ." Frame ct at HCCA at end OF enumeration = " +\ hchcca 80 + rl@-le . +\ LOOP +\ ; + +\ ============================================================================ +\ COLON DEFINITION: HC-reset +\ This routine should be the first to be executed. +\ This routine will reset the HC and will bring it to Operational +\ state. +\ PENDING: +\ Arrive at the right value OF FrameInterval. Currently we are hardcoding +\ it. +\ ========================================================================== +: HC-reset ( -- ) + + hccomstat dup rl@-le 01 or swap rl!-le \ issue HC reset + BEGIN + hccomstat rl@-le 01 and 0<> \ wait for reset end + WHILE + REPEAT + + 23f02edf hcintrval rl!-le \ frame-interval register + hchcca hchccareg rl!-le \ HC communication area + 0000 hcctrhead rl!-le \ control transfer head + 0000 hcbulkhead rl!-le \ bulk transfer head + 0ffff hcintdsbl rl!-le \ interrupt disable reg. + +\ all devices are still in reset-state +\ next command starts sending SOFs + 83 hccontrol rl!-le \ set USBOPERATIONAL + +\ these two repeated register settings are necessary for Bimini +\ Its OHCI controller (AM8111) behaves different to NEC's one + 23f02edf hcintrval rl!-le \ frame-interval register + hchcca hchccareg rl!-le \ HC communication area + + d# 50 ms + + hcrhdescA rl@-le ff and ( total-rh-ports ) + to max-rh-ports + +\ if no hardware-reset was issued (rescan) +\ switch off all ports first ! + hcrhpstat TO current-stat \ start with first port status reg + 0 \ port status default + max-rh-ports 0 \ checking all ports + DO + current-stat rl@-le or \ OR-ing all stats + 200 current-stat rl!-le \ Clear Port Power (CPP) + current-stat 4 + TO current-stat \ check next RH-Port + LOOP + 100 and 0<> \ any of the ports had power ? + IF + d# 750 wait-proceed \ wait for power discharge + THEN + +\ now power on all ports of this root-hub + hcrhpstat TO current-stat \ start with first port status reg + max-rh-ports 0 + DO + 102 current-stat rl!-le \ power on and enable + hcrhdescA 3 + rb@ 2 * ms \ startup delay 30 ms (2 * POTPGT) + current-stat 4 + TO current-stat \ check next RH-Port + LOOP + d# 500 wait-proceed \ STEC device needs 300 ms +; + +: error-recovery ( -- ) + initialize-td-free-list + initialize-ed-free-list + HC-reset +; + +\ ================================================================ +: store-initial-usb-hub-address ( -- ) + usb-address TO initial-hub-address +; + +: reset-to-initial-usb-hub-address ( -- ) + initial-hub-address TO usb-address +; + +\ allocate-usb-address: +\ Function allocates an USB address. +\ See RISK below. + + +: allocate-usb-address ( -- usb-address ) + usb-address 7f <> ( TRUE|FALSE ) + IF + usb-address 1+ TO usb-address \ RISK: Check to see IF it overflows 127 + usb-address ( usb-address ) + THEN ( usb-address ) +; + +s" usb-support.fs" INCLUDED + + + +\ ===================================================================== +\ COLON DEFINTION: control-std-set-address +\ INTERFACE FUNCTION +\ Function allocates an USB addrss and uses it to send SET-ADDRESS packet +\ to the default USB address. +\ This is an interface function available to child nodes. + +: control-std-set-address ( speedbit -- usb-address TRUE | FALSE ) + >r ( R: speedbit ) + 0005000000000000 setup-packet ! + allocate-usb-address dup setup-packet 2 + c! ( usb-addr R: speedbit ) + s" USB set-address: " 2 pick usb-debug-print-val ( usb-addr R: speedbit ) + 0 0 0 setup-packet 8 r> controlxfer ( usb-addr TRUE | FALSE ) + IF ( TRUE | FALSE ) + TRUE ( TRUE ) + ELSE + drop FALSE \ PENDING: Return the allocated address back. ( FALSE ) + THEN ( TRUE | FALSE ) +; + + +\ Fetches the device decriptor of the usb-device + + +: control-std-get-device-descriptor + ( data-buffer data-len MPS fa -- TRUE|FALSE ) + + 8006000100000000 setup-packet ! + 2 pick setup-packet 6 + w!-le + ( data-buffer data-len MPS fa ) + setup-packet -rot ( data-buffer data-len setup-packet MPS fa ) + >r >r >r >r >r 0 r> r> r> r> r> + ( 0 data-buffer data-len setup-packet MPS fa ) + controlxfer ( TRUE | FALSE ) +; + + +\ ================================================================== +\ To retrieve the configuration descriptor OF a device +\ with a valid USB address + + +: control-std-get-configuration-descriptor + ( data-buffer data-len MPS FuncAddr -- TRUE|FALSE ) + TO temp1 ( data-buffer data-len MPS ) + TO temp2 ( data-buffer data-len ) + TO temp3 ( data-buffer ) + 8006000200000000 setup-packet ! + temp3 setup-packet 6 + w!-le + 0 swap temp3 setup-packet temp2 temp1 controlxfer +; + +\ Fetches num of logical units available for a device +: control-std-get-maxlun ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE ) + GET-MAX-LUN setup-packet ! ( MPS fun-addr dir data-buff data-len ) + setup-packet 5 pick 5 pick + ( MPS fun-addr dir data-buff data-len setup-packet MPS fun-addr ) + controlxfer ( MPS fun-addr TRUE | FALSE ) + nip nip ( TRUE | FALSE ) +; + +\ Bulk-Only Mass Storage Reset +\ fixed to interface #0 +: control-bulk-reset ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE ) + 21FF000000000000 setup-packet ! ( MPS fun-addr dir data-buff data-len ) + setup-packet 5 pick 5 pick + ( MPS fun-addr dir data-buff data-len setup-packet MPS fun-addr ) + controlxfer ( MPS fun-addr TRUE | FALSE ) + nip nip ( TRUE | FALSE ) +; + + + +\ get the string descriptor of the usb device + + +: control-std-get-string-descriptor + ( StringIndex data-buffer data-len MPS FuncAddr -- TRUE | FALSE ) + TO temp1 ( StringIndex data-buffer data-len MPS ) + TO temp2 ( StringIndex data-buffer data-len ) + TO temp3 ( StringIndex ) + 8006000300000000 setup-packet ! + temp3 setup-packet 6 + w!-le + 409 setup-packet 4 + w!-le \ US English Language code. + swap ( data buffer StringIndex ) + setup-packet 2 + c! ( data-buffer ) + 0 swap temp3 setup-packet temp2 temp1 controlxfer ( TRUE | FALSE ) +; + +\ sets a valid usb configaration for a device + +: control-std-set-configuration ( configvalue FuncAddr -- TRUE|FALSE ) + TO temp1 ( configvalue ) + TO temp2 + 0009000000000000 setup-packet ! \ RISK: Endian and 64-bit assumptions + temp2 setup-packet 2 + w!-le + 0 0 0 setup-packet DEFAULT-CONTROL-MPS temp1 controlxfer + + \ NOTE: We could use DEFAULT-CONTROL-MPS because there is no data phase + \ associated with this control xfer. Its a dont care. +; + + +\ To set the device address retrive the device descriptor and build the +\ usb device tree by passing device class + + +0 VALUE port-number + +s" usb-enumerate.fs" INCLUDED + +: rhport-enumerate ( port-num -- ) + TO port-number + device-speed control-std-set-address ( usb-addr TRUE | FALSE ) + IF + device-speed or ( usb-addr+speedbit ) + TO new-device-address + dd-buffer @ 8 erase + + \ Read Device Descriptor - First 8 bytes. + + dd-buffer @ DEFAULT-CONTROL-MPS DEFAULT-CONTROL-MPS ( buffer mps mps ) + new-device-address control-std-get-device-descriptor ( TRUE | FALSE ) + IF + ELSE + s" USB: Read Dev Descriptor failed" usb-debug-print EXIT + + \ NOTE: Tomorrow, IF there is a LOOP here,we may need to UNLOOP before + \ "EXIT"ing. Beware. Much depends on what LOOPing construct is used. + + THEN + + \ Read the Descriptor Type and check IF we have read correctly. + + dd-buffer @ DEVICE-DESCRIPTOR-TYPE-OFFSET + c@ ( Descriptor-type ) + DEVICE-DESCRIPTOR-TYPE <> IF + s" USB: Error Reading Device Descriptor" usb-debug-print + s" Read descriptor is not OF the right type" usb-debug-print + s" Aborting enumeration" usb-debug-print + EXIT + \ NOTE: Tomorrow, IF u have a LOOP here THEN we may need to + \ UNLOOP before EXITing. Depends on what type OF LOOPing construct + \ is used. Beware. + + THEN + + \ Read the MPS and store it. + + dd-buffer @ DEVICE-DESCRIPTOR-MPS-OFFSET + c@ TO mps + + \ NOTE: Probably, we could check MPS for only 8/16/32/64 + \ hmm.. not now... + + \ Read the device class to see what type OF device it is and create an + \ appropriate child node here. + create-usb-device-tree + ELSE + s" Set address failed on port " port-number usb-debug-print-val + s" Aborting Enumeration." usb-debug-print + EXIT + + \ NOTE: Tomorrow , IF u have a LOOP here THEN we may need to + \ UNLOOP before EXITing. Depends on what type OF LOOPing construct + \ is used. Beware. + + THEN +; + + +\ ========================================================================= +\ PROTOTYPE FUNCTION: "rhport-initialize" +\ Detect Device, reset and enable the respective port. +\ COLON Definition rhport-initialize accepts the total number OF root hub +\ ports as an argument and probes every available root hub port and initiates +\ the build OF the USB devie sub-tree so is effectively the mother OF all +\ USB device nodes that are to be detected and instantiated. +\ ========================================================================== +: rhport-initialize ( -- ) + + hcrhpstat TO current-stat \ start with first port status reg + max-rh-ports 1+ 1 + DO + \ any Device connected to that port ? + current-stat rl@-le RHP-CCS and 0<> ( TRUE|FALSE ) + IF + current-stat hcrhpstat3 = \ third port of NEC ? + IF + 81 to uDOC-present \ uDOC is present and now processed + THEN + + s" Device connected to this port!" usb-debug-print + RHP-PRS current-stat rl!-le \ issue a port reset + BEGIN + current-stat rl@-le RHP-PRS AND \ wait for reset end + WHILE + REPEAT + hcrhdescA 3 + rb@ 2 * ms \ startup delay 30 ms (POTPGT) + d# 100 ms + + current-stat rl@-le 200 and 4 lshift + to device-speed \ store speed bit + + RHP-CSC RHP-PRSC or current-stat rl!-le + + I ['] rhport-enumerate CATCH IF \ Scan port + s" USB scan failed on root hub port: " rot usb-debug-print-val + reset-to-initial-usb-hub-address + THEN + + ELSE + s" No device detected at this port." usb-debug-print + current-stat hcrhpstat3 = \ third port of NEC ? (=ModFD) + IF \ here a ModFD should be on ELBA + current-stat rl@-le 80000 and 0<> \ is over-current detected ? + IF + uDOC-present 08 or to uDOC-present \ set flag for uDOC-check + THEN + THEN + THEN + current-stat 4 + TO current-stat \ check next RH-Port + uDOC-present 0f and to uDOC-present \ remove processing flag + LOOP +; + + +\ =================================================== +\ Enumeration at Host level +\ =================================================== + +: enumerate ( -- ) + HC-reset + ['] hc-suspend add-quiesce-xt \ Assert that HC will be supsended + store-initial-usb-hub-address + rhport-initialize \ Probe all available RH ports + reset-to-initial-usb-hub-address +; + + +\ Create an alias for this controller: +set-ohci-alias + diff --git a/slof/fs/usb/usb-static.fs b/slof/fs/usb/usb-static.fs new file mode 100644 index 0000000..8732957 --- /dev/null +++ b/slof/fs/usb/usb-static.fs @@ -0,0 +1,297 @@ +\ ***************************************************************************** +\ * 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 "scsi-support.fs" + +\ Set usb-debug flag to TRUE for debugging output: +0 VALUE usb-debug-flag +false VALUE scan-time? + +VARIABLE ihandle-bulk-tran +\ -scsi-supp- VARIABLE ihandle-scsi-tran + +\ uDOC (Micro-Disk-On-Chip) is a FLASH-device +\ normally connected to usb-port 5 on ELBA +\ +0 VALUE uDOC-present \ device present and working? + +\ Print a debug message when usb-debug-flag is set +: usb-debug-print ( str len -- ) + usb-debug-flag IF type cr ELSE 2drop THEN +; + +\ Print a debug message with corresponding value when usb-debug-flag is set +: usb-debug-print-val ( str len val -- ) + usb-debug-flag IF -ROT type . cr ELSE drop 2drop THEN +; + +\ show proceeding propeller only during scan process. +\ As soon USB-keyboard can be used, this must be suppressed. +0 VALUE proceed-char +: show-proceed ( -- ) + scan-time? \ are we on usb-scan ? + IF + proceed-char + CASE + 0 OF 2d ENDOF \ show '-' + 1 OF 5c ENDOF \ show '\' + 2 OF 7c ENDOF \ show '|' + dup OF 2f ENDOF \ show '/' + ENDCASE + emit 8 emit + proceed-char 1 + 3 AND to proceed-char + THEN +; + +\ delay with proceeding signs +: wait-proceed ( nl -- ) + show-proceed + BEGIN + dup d# 100 > ( nl true|false ) + WHILE + 100 - show-proceed + 100 ms \ do it in steps of 100ms + REPEAT + ms \ rest delay +; + +\ register device alias +: do-alias-setting ( num name-str name-len ) + rot $cathex strdup \ create alias name + get-node node>path \ get path string + set-alias \ and set the alias +; + + +0 VALUE ohci-alias-num + +\ create a new ohci device alias for the current node: +: set-ohci-alias ( -- ) + ohci-alias-num dup 1+ TO ohci-alias-num ( num ) + s" ohci" + do-alias-setting +; + +0 VALUE cdrom-alias-num +0 VALUE disk-alias-num \ shall start with: pci-disk-num +FALSE VALUE ext-disk-alias \ first external disk: not yet assigned + +\ create a new ohci device alias for the current node: +: set-drive-alias ( -- ) + space 5b emit + s" cdrom" drop ( name-str ) + get-node node>name comp 0= ( true|false ) + IF \ is this a cdrom ? + cdrom-alias-num dup 1+ TO cdrom-alias-num ( num ) + s" cdrom" \ yes, alias = cdrom + ELSE + s" sbc-dev" drop \ is this a scsi-block-device? + get-node node>name comp 0= ( true|false ) + IF + disk-alias-num dup 1 + to disk-alias-num + s" disk" \ all block devices will be named "disk" + + \ this is a block-device. + \ check if parent is 'usb' and not 'hub' + \ if so this block-device is directly connected + \ to root-hub and must be the uDOC-device in Elba + s" usb" drop \ parent = usb controller ? (not hub) + get-node node>parent @ node>name + comp 0= \ parent node starts with 'usb' ? + IF ( true|false ) + 1 s" hdd" \ add extra alias hdd1 for IntFlash + 2dup type 2 pick . + 8 emit 2f emit + do-alias-setting + uDOC-present 1 and + IF + uDOC-present 2 or to uDOC-present \ present and ready + THEN + ELSE + ext-disk-alias not \ flag for first ext. disk already assigned + IF + TRUE to ext-disk-alias + 2 s" hdd" \ add extra alias hdd2 for first USB disk + 2dup type 2 pick . + 8 emit 2f emit + do-alias-setting + THEN + THEN + ELSE + 0 s" ??? " \ unknown device + THEN + THEN ( num name-str name-len ) + 2dup type 2 pick . + 8 emit 5d emit cr + do-alias-setting +; + +: usb-create-alias-name ( num -- str len ) + >r s" ohciX" 2dup + 1- ( str len last-char-ptr R: num ) + r> [char] 0 + swap c! ( str len R: ) +; + + +\ ***************************************************** +\ This is a final check to see, if a uDOC-device +\ is ready for booting +\ If physically present, but not working, an +\ Error-LED must be activated (on ELBA only!) +\ ***************************************************** +\ uDOC is now replaced by ModFD (Modular-Flash-Drive) +\ due to right properties +\ 'sys-signal-modfd-fault' sends an IPMI-Message to +\ aMM for generating a log entry and to switch on +\ an error LED (call to libsystem->libipmi) +\ ***************************************************** +\ although there are IPMI-warnings defined concerning +\ detected media errors, it doesn't make sense to send +\ a warning when booting from this device is impossible. +\ The decision was made to send an error call in this +\ case as well +\ ***************************************************** +\ uDOC-present bits: +\ ***************************************************** +\ D0: any device is connected on port 3 of root-hub +\ D1: device on port 3 is directly connected (no hub) +\ D2: warnings were received (scancodes) +\ D3: OverCurrentIndicator on USB-Port was set +\ D7: flag, set while ModFD is beeing processed + +: uDOC-check ( -- ) +#ifdef ELBA + uDOC-present 7 and \ flags concerning ModFD device + CASE + 0 OF \ not present not detected + uDOC-present 8 and 0<> \ not detected due to OverCurrent? + IF + 0d emit ." * OverCurrent on ModFD *" cr + sys-signal-modfd-fault ( -- ) \ send IPMI-call to BMC + ELSE + 0d emit ." ModFD not present" cr + THEN + ENDOF + + 1 OF \ present but not detected by USB + 0d emit ." * ModFD not accessible *" cr + sys-signal-modfd-fault ( -- ) \ send IPMI-call to BMC + ENDOF + + 3 OF \ present and detected +\ 0d emit ." ModFD OK" cr + ENDOF + + 7 OF \ present and detected but with warnings + 0d emit ." * ModFD Warnings *" cr + sys-signal-modfd-fault ( -- ) \ send IPMI-call to BMC + ENDOF + + dup OF \ we have a fault in our firmware ! + s" *** ModFD detection error ***" usb-debug-print + ENDOF + ENDCASE +#endif +; + +\ ***************************************************** +\ check if actual processed device is ModFD and +\ then sets its warning bit +\ ***************************************************** +: uDOC-failure? ( -- ) + uDOC-present 80 and 0<> \ is ModFD actual beeing processed? + IF + uDOC-present 04 or to uDOC-present \ set Warning flag + THEN +; + +\ Scan all USB host controllers for attached devices: +: usb-scan + \ Scan all OHCI chips: + space ." Scan USB... " cr + true to scan-time? \ show proceeding signs + 0 to uDOC-present \ mark as not present + 0 to disk-alias-num \ start with disk0 + s" pci-disk-num" $find \ previously detected disks ? + IF + execute to disk-alias-num \ overwrite start number + ELSE + 2drop + THEN + + 0 >r \ Counter for alias + BEGIN + r@ usb-create-alias-name + find-alias ?dup ( false | str len len R: num ) + WHILE + usb-debug-flag IF + ." * Scanning hub " 2dup type ." ..." cr + THEN + open-dev ?dup IF ( ihandle R: num ) + dup to my-self + dup ihandle>phandle dup set-node + child ?dup IF + delete-node s" Deleting node" usb-debug-print + THEN + >r s" enumerate" r@ $call-method \ Scan host controller + r> close-dev 0 set-node 0 to my-self + THEN ( R: num ) + r> 1+ >r ( R: num+1 ) + REPEAT r> drop + 0 TO ohci-alias-num + 0 TO cdrom-alias-num + s" cdrom0" find-alias ( false | dev-path len ) + dup IF + s" cdrom" 2swap ( alias-name len' dev-path len ) + set-alias ( -- ) + \ cdrom-alias-num 1 + TO cdrom-alias-num + ELSE + drop ( -- ) + THEN + uDOC-check \ check if uDOC-device is present and working (ELBA only) + false to scan-time? \ suppress proceeding signs +; + +: usb-probe + + usb-scan + + cdrom-alias-num 0= IF + ." Not found CDROM! " cr + THEN + ." CDROM found " cdrom-alias-num . cr +; + + +: usb-dev-test ( -- TRUE ) + s" USB Device Test " usb-debug-print + 1 usb-create-alias-name + find-alias ?dup IF + ." * open " 2dup type . cr + ELSE + s" can't found alias " usb-debug-print + THEN + open-dev ?dup IF + dup to my-self + dup ihandle>phandle dup set-node + s" bulk" $open-package ihandle-bulk-tran ! +\ make-media-ready + s" close all " usb-debug-print + close-dev 0 set-node 0 to my-self + + ihandle-bulk-tran close-package + ELSE + s" can't open usb hub" usb-debug-print + THEN + + TRUE +; + diff --git a/slof/fs/usb/usb-storage-support.fs b/slof/fs/usb/usb-storage-support.fs new file mode 100644 index 0000000..f5033de --- /dev/null +++ b/slof/fs/usb/usb-storage-support.fs @@ -0,0 +1,155 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ --------------------------------------------------------------------------- +\ Parent methods +\ --------------------------------------------------------------------------- + +: rw-endpoint + ( pt ed-type toggle buffer length mps addres -- toggle TRUE | toggle FALSE ) + s" rw-endpoint" $call-parent + ( toggle TRUE | toggle FALSE ) +; + +: controlxfer ( dir addr dlen setup-packet MPS ep-fun --- TRUE|FALSE ) + s" controlxfer" $call-parent + ( TRUE | FALSE ) +; + +: control-std-get-configuration-descriptor + ( data-buffer data-len MPS FuncAddr -- TRUE | FALSE ) + s" control-std-get-configuration-descriptor" $call-parent + ( TRUE | FALSE ) +; + +: control-std-set-configuration ( configvalue FuncAddr -- TRUE | FALSE ) + s" control-std-set-configuration" $call-parent ( TRUE | FALSE ) +; + +: bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- ) + s" bulk-reset-recovery-procedure" $call-parent +; + + +\ --------------------------------------------------------------------------- +\ Bulk support package methods +\ --------------------------------------------------------------------------- + +: build-cbw ( address tag transfer-len direction lun command-len -- ) + s" build-cbw" ihandle-bulk @ $call-method +; + +: analyze-csw ( address -- residue tag TRUE | reason FALSE ) + s" analyze-csw" ihandle-bulk @ $call-method + ( residue tag TRUE | reason FALSE ) +; + + +\ ======================================================= +\ NATIVE METHODS USED EITHER AT PROBE TIME OR TIME +\ WHEN INSTANCE IS CREATED +\ ======================================================= + + +\ -------------------------------------------------------- +\ COLON DEFINITION: the method is a probe-time method +\ used to: +\ 1. decode the properties and store in variables +\ 2. allocat buffers required for the device and +\ 3. set the right configuration after extracting the +\ configuration descriptor +\ -------------------------------------------------------- + +: device-init ( -- ) + s" Starting to initialize usb-storage device" usb-debug-print + s" USB-ADDRESS" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" not possible" usb-debug-print + ELSE + decode-int nip nip to my-usb-address + THEN + s" MPS-BULKOUT" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" not possible" usb-debug-print + ELSE + decode-int nip nip to mps-bulk-out + THEN + s" MPS-BULKIN" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" not possible" usb-debug-print + ELSE + decode-int nip nip to mps-bulk-in + THEN + s" BULK-IN-EP-ADDR" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" not possible" usb-debug-print + ELSE + decode-int nip nip to bulk-in-ep + THEN + s" BULK-OUT-EP-ADDR" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" not possible" usb-debug-print + ELSE + decode-int nip nip to bulk-out-ep + THEN + s" MPS-DCP" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" Not possible" usb-debug-print + ELSE + decode-int nip nip to mps-dcp + THEN + s" LUN" get-my-property ( TRUE | propaddr proplen FALSE ) + IF + s" NOT Possible to extract LUN" usb-debug-print + ELSE + decode-int nip nip to lun + THEN + s" Extracted properties inherited from parent." usb-debug-print + + \ PENDING: + \ Do some return value check here... + + 40 alloc-mem to command-buffer + 80 alloc-mem to response-buffer + 10 alloc-mem to csw-buffer + 8 alloc-mem to cfg-buffer + s" Allocated buffers." usb-debug-print + cfg-buffer 8 mps-dcp my-usb-address ( buffer len mps fun-addr ) + control-std-get-configuration-descriptor ( TRUE | FALSE ) + drop + s" Configuration descriptor extracted." usb-debug-print + cfg-buffer 5 + c@ my-usb-address ( configvalue fun-addr ) + control-std-set-configuration ( TRUE | FALSE ) + s" usb-storage: Set config returned: " rot usb-debug-print-val +; + + +\ ---------------------------------------------------- +\ Internal methods +\ ---------------------------------------------------- + + +: (open-package) ( ihandle-var name-str name-len -- ) + find-package IF ( ihandle-var phandle ) + 0 0 rot open-package ( ihandle-var ihandle ) + swap ! + ELSE + s" Support package not found" usb-debug-print + THEN +; + +: (close-package) ( ihandle-var -- ) + dup @ close-package + 0 swap ! +; + diff --git a/slof/fs/usb/usb-storage-wrapper.fs b/slof/fs/usb/usb-storage-wrapper.fs new file mode 100644 index 0000000..c783541 --- /dev/null +++ b/slof/fs/usb/usb-storage-wrapper.fs @@ -0,0 +1,181 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + +\ ----------------------------------------------------------- +\ OF properties +\ ----------------------------------------------------------- + +s" scsi" device-name +s" block-type" device-type +1 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + + +: encode-unit 1 hex-encode-unit ; + +: decode-unit 1 hex-decode-unit ; + + +\ ----------------------------------------------------------- +\ Specific properties +\ ----------------------------------------------------------- + +1 chars alloc-mem VALUE ch-buffer +8 VALUE mps-dcp +0 VALUE port-number +0 VALUE my-usb-address + + +: control-std-get-maxlun + ( MPS fun-addr dir data-buff data-len -- TRUE | FALSE ) + s" control-std-get-maxlun" $call-parent +; + + +: control-std-get-configuration-descriptor + ( data-buffer data-len MPS funcAddr -- TRUE|FALSE ) + s" control-std-get-configuration-descriptor" $call-parent +; + +: rw-endpoint + ( pt ed-type toggle buffer length mps address -- toggle TRUE|toggle FALSE ) + s" rw-endpoint" $call-parent +; + +: controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE|FALSE ) + s" controlxfer" $call-parent +; + +: control-std-set-configuration + ( configvalue FuncAddr -- TRUE|FALSE ) + s" control-std-set-configuration" $call-parent +; + +\ This method is used for extracting the properties from it's parent and +\ storing these value to temporary variable so that they can used later. + +: extract-properties ( -- ) + s" USB-ADDRESS" get-inherited-property ( prop-addr prop-len FALSE | TRUE ) + IF + s" notpossible" usb-debug-print + ELSE + decode-int nip nip to my-usb-address + THEN + s" MPS-DCP" get-inherited-property ( prop-addr prop-len FALSE | TRUE ) + IF + s" MPS-DCP property not found.Assume 8 as MAX PACKET SIZE" usb-debug-print + s" for the default control pipe" usb-debug-print + 8 to mps-dcp + ELSE + s" MPS-DCP property found!!" usb-debug-print + decode-int nip nip to mps-dcp + THEN + s" reg" get-inherited-property ( prop-addr prop-len FLASE | TRUE ) + IF + s" notpossible" usb-debug-print + ELSE + decode-int nip nip to port-number + THEN +; + + +\ This method is used for creating the child nodes for every Logical unit +\ available in the device, this method will call control-std-get-maxlun for +\ for finding the maximum Logical units supported by the device and along with +\ the creation of nodes this method encodes the properties of the node also. + +: create-tree ( -- ) + mps-dcp my-usb-address 0 ch-buffer 1 ( MPS fun-addr dir data-buff data-len ) + control-std-get-maxlun ( TRUE | FALSE ) + + \ This method extracts the maximum number of Logical Units Supported by + \ the Device . if no Logical Units are present then 0 will be taken as the + \ max logical units. if the device doesn't support the GET-MAX-LUN command + \ then the device may can be stalled as a temporary fix to come out from + \ the stalling situations we can issue the control-std-set-configuration with + \ appropriate arguments + + + IF + s" GET-MAX-LUN IS WORKING :" usb-debug-print + ELSE + s" ERROR in GET-MAX-LUN " usb-debug-print + THEN + ch-buffer c@ 1 + 0 ( max-lun+1 0 ) + DO + s" iManufacturer" get-inherited-property drop ( prop-addr prop-len TRUE ) + decode-int nip nip ( iManu ) + s" iProduct" get-inherited-property drop + ( iManu prop-addr prop-len TRUE | FALSE ) + decode-int nip nip ( iManu iProd ) + s" iSerialNumber" get-inherited-property drop + ( iManu iProd prop-addr prop-len TRUE | FALSE ) + decode-int nip nip ( iManu iProd iSerNum ) + s" MPS-BULKOUT" get-inherited-property drop + ( iManu iProd iSerNum prop-len prop-addr TRUE | FALSE ) + decode-int nip nip ( iManu iProd iSerNum MPS-BULKOUT ) + s" BULK-OUT-EP-ADDR" get-inherited-property drop + ( iManu iProd iSerNum MPS-BULKOUT prop-addr prop-len TRUE|FALSE ) + decode-int nip nip ( iManu iProd iSerNum MPS-BULKOUT BULK-OUT-EP-ADDR ) + s" MPS-BULKIN" get-inherited-property drop + ( iManu iProd iSerNum MPS-BULKOUT BULK-OUT-EP-ADDR prop-addr prop-len + TRUE | FALSE ) + decode-int nip nip + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN ) + s" BULK-IN-EP-ADDR" get-inherited-property drop + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN prop-addr + prop-len TRUE | FALSE ) + decode-int nip nip + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR ) + mps-dcp port-number my-usb-address I + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR mps-dcp port-address my-usb-address lun-number ) + new-device + + \ creates new device child node, doesn't consume any argument from stack + + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR mps-dcp port-address my-usb-address lun-number ) + + set-space + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR mps-dcp port-number my-usb-address ) + encode-int s" USB-ADDRESS" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR mps-dcp port-number ) + encode-int s" reg" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN ) + ( BULKIN-EP-ADDR mps-dcp port-number ) + encode-int s" MPS-DCP" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR ) + I encode-int s" LUN" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN + BULKIN-EP-ADDR ) + encode-int s" BULK-IN-EP-ADDR" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR MPS-BULKIN ) + encode-int s" MPS-BULKIN" property + ( iManu iProd iSernum MPS-BULKOUT BULK-OUT-EP-ADDR ) + encode-int s" BULK-OUT-EP-ADDR" property + ( iManu iProd iSernum MPS-BULKOUT ) + encode-int s" MPS-BULKOUT" property ( iManu iProd iSerNum ) + encode-int s" iSerialNumber" property ( iManu iProd ) + encode-int s" iProduct" property ( iManu ) + encode-int s" iManufacturer" property ( -- ) + s" usb-storage.fs" INCLUDED + finish-device + LOOP +; + +extract-properties \ Extract the properties from parent +create-tree \ this method creates the node for every lun with properties diff --git a/slof/fs/usb/usb-storage.fs b/slof/fs/usb/usb-storage.fs new file mode 100644 index 0000000..f23c27a --- /dev/null +++ b/slof/fs/usb/usb-storage.fs @@ -0,0 +1,639 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ + + +\ ----------------------------------------------------------- +\ OF properties +\ ----------------------------------------------------------- + +s" storage" device-name +s" block" device-type + +2 encode-int s" #address-cells" property +0 encode-int s" #size-cells" property + +\ ----------------------------------------------------------- +\ Specific properties +\ ----------------------------------------------------------- + +8 VALUE mps-bulk-out +8 VALUE mps-bulk-in +8 VALUE mps-dcp +0 VALUE bulk-in-ep +0 VALUE bulk-out-ep +0 VALUE bulk-in-toggle +0 VALUE bulk-out-toggle +0 VALUE lun +0 VALUE my-usb-address + + +\ ---------------------------------------------------------- +\ Instance specific values +\ ---------------------------------------------------------- + +0 VALUE csw-buffer +0e VALUE cfg-buffer +0 VALUE response-buffer +0 VALUE command-buffer +0 VALUE resp-size +0 VALUE resp-buffer +INSTANCE VARIABLE ihandle-bulk +INSTANCE VARIABLE ihandle-deblocker +INSTANCE VARIABLE flag +INSTANCE VARIABLE count +0 VALUE max-transfer +200 VALUE block-size \ default (512 Bytes) +-1 VALUE max-block-num \ highest reported block-number + + +\ ------------------------------------------------------- +\ General Constants +\ ------------------------------------------------------- + +0f CONSTANT SCSI-COMMAND-OFFSET + + +\ ------------------------------------------------------- +\ All support methods inherited from parent or imported +\ from support packages are included here. Also included +\ are the internal methods +\ ------------------------------------------------------- + +s" usb-storage-support.fs" INCLUDED + +\ --------------------------------------------------------------- +\ COLON Definitions: Implementation of Standard SCSI commands +\ over USB OHCI +\ --------------------------------------------------------------- + + +\ to use the general bulk command a lot of global variables +\ must be set. See for example the inquiry command. +0 VALUE bulk-cnt +0 VALUE bulk-cmd-len +0 VALUE itest +: do-bulk-command ( resp-buffer resp-size -- TRUE | FALSE ) + TO resp-size + TO resp-buffer + \ dump buffer in debug-mode + usb-debug-flag + IF + command-buffer 0E + c@ TO bulk-cmd-len + s" cmd-length: " bulk-cmd-len usb-debug-print-val + command-buffer bulk-cmd-len 0E + dump cr + THEN + + 6 TO bulk-cnt \ 2 old value + FALSE dup + BEGIN + 0= + WHILE + drop + \ prepare and send bulk CBW + 1 1 bulk-out-toggle command-buffer 1f mps-bulk-out + ( pt ed-type toggle buffer length mps-bulk-out ) + my-usb-address bulk-out-ep 7 lshift or + ( pt ed-type toggle buffer length mps address ) + rw-endpoint swap ( TRUE toggle | FALSE toggle ) + to bulk-out-toggle ( TRUE | FALSE ) + IF + s" resp-size : " resp-size usb-debug-print-val + resp-size 0<> + IF \ do we need a response ?! + \ read the bulk response + 0 1 bulk-in-toggle resp-buffer resp-size mps-bulk-in + ( pt ed-type toggle buffer length mps-bulk-in ) + my-usb-address bulk-in-ep 7 lshift or + ( pt ed-type toggle buffer length mps address ) + rw-endpoint swap ( TRUE toggle | FALSE toggle ) + to bulk-in-toggle ( TRUE | FALSE ) + ELSE + TRUE + THEN + IF \ read the bulk CSW + 0 1 bulk-in-toggle csw-buffer D mps-bulk-in + ( pt ed-type toggle buffer length mps-bulk-in ) + my-usb-address bulk-in-ep 7 lshift or + ( pt ed-type toggle buffer length mps address ) + rw-endpoint swap ( TRUE toggle | FALSE toggle ) + to bulk-in-toggle ( TRUE | FALSE ) + IF + s" Command successful." usb-debug-print + TRUE dup + ELSE + s" Command failed in CSW stage" usb-debug-print + FALSE dup + THEN + ELSE + s" Command failed while receiving DATA... read CSW..." usb-debug-print + \ STALLED: Get CSW to send the CBW again + 0 1 bulk-in-toggle csw-buffer D mps-bulk-in + ( pt ed-type toggle buffer length mps-bulk-in ) + my-usb-address bulk-in-ep 7 lshift or + ( pt ed-type toggle buffer length mps address ) + rw-endpoint swap ( TRUE toggle | FALSE toggle ) + to bulk-in-toggle ( TRUE | FALSE ) + IF + s" OK evaluate the CSW ..." usb-debug-print + csw-buffer c + c@ dup TO itest + s" CSW Status: " itest usb-debug-print-val + dup + 2 = + IF \ Phase Error + s" Phase error do a bulk reset-recovery ..." usb-debug-print + bulk-out-ep bulk-in-ep my-usb-address + bulk-reset-recovery-procedure + THEN + \ ELSE + \ don't abort if the read fails. + 1 = + IF \ Command failed + s" Command Failed do a bulk-reset-recovery" usb-debug-print + bulk-out-ep bulk-in-ep my-usb-address + bulk-reset-recovery-procedure + THEN + THEN + FALSE dup + THEN + ELSE + s" Command failed while Sending CBW ..." usb-debug-print + FALSE dup + THEN + bulk-cnt 1 - TO bulk-cnt + bulk-cnt 0= + IF + 2drop FALSE dup + THEN + REPEAT +; + + +\ --------------------------------------------------------------- +\ Method to 1. Send the INQUIRY command 2. Receive and analyse +\ (pending) INQUIRY data +\ --------------------------------------------------------------- +scsi-open +usb-debug-flag to scsi-param-debug \ copy debug flag + +24 CONSTANT inquiry-length \ was 20 + +: inquiry ( -- ) + s" usb-storage: inquiry" usb-debug-print + command-buffer 1 inquiry-length 80 lun scsi-length-inquiry + ( address tag transfer-len direction lun command-len ) + build-cbw + inquiry-length command-buffer SCSI-COMMAND-OFFSET + ( alloc-len address ) + scsi-build-inquiry + response-buffer inquiry-length erase \ provide clean buffer + response-buffer inquiry-length do-bulk-command + IF + s" Successfully read INQUIRY data" usb-debug-print + 0d emit space space + response-buffer c@ \ get 'Peripheral Device Type' (PDT) + CASE + 0 OF ." BLOCK-DEV: " ENDOF \ SCSI Block Device + 5 OF ." CD-ROM : " ENDOF + 7 OF ." OPTICAL : " ENDOF + e OF ." RED-BLOCK: " ENDOF \ SCSI Reduced Block Device + dup dup OF ." ? (" . 8 emit 29 emit 2 spaces ENDOF + ENDCASE + space + \ create vendor identification in device property + response-buffer 8 + 16 encode-string s" ident-str" property + response-buffer .inquiry-text + ELSE + 5040 error" (USB) Device transaction error. (inquiry)" + ABORT + THEN +; + +\ --------------------------------------------------------------- +\ Method to 1. Send the READ CAPACITY command +\ 2. Recieve and analyse the response data +\ --------------------------------------------------------------- + +: read-capacity ( -- ) + s" usb-storage: read-capacity" usb-debug-print + command-buffer 1 8 80 lun scsi-length-read-cap-10 + ( address tag transfer-len direction lun command-len ) + build-cbw + \ command-buffer 30 dump cr \ dump the command buffer + command-buffer SCSI-COMMAND-OFFSET + ( address ) + scsi-build-read-cap-10 + lun 5 lshift + command-buffer SCSI-COMMAND-OFFSET + ( address ) + read-cap-10>reserved1 c! + + response-buffer 8 erase \ provide clean buffer + response-buffer 8 do-bulk-command + IF + s" Successfully read READ CAPACITY data" usb-debug-print + ELSE + 5040 error" (USB) Device transaction error. (capacity)" + ABORT + THEN +; + + +\ ------------------------------------------------------------------- +\ Method to 1. Send TEST UNIT READY command 2. Analyse the status +\ of the response +\ ------------------------------------------------------------------- + +: test-unit-ready ( -- TRUE | FALSE ) + command-buffer 1 0 80 lun scsi-length-test-unit-ready \ was: 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + ( address ) + scsi-build-test-unit-ready ( cdb -- ) + response-buffer 0 do-bulk-command + IF + s" Successfully read test unit ready data" usb-debug-print + s" Test Unit STATUS availabe in csw-buffer" usb-debug-print + csw-buffer 0c + c@ 0= IF + s" Test Unit Command Successfully Executed" usb-debug-print + TRUE ( TRUE ) + ELSE + s" Test Unit Command Failed to execute" usb-debug-print + FALSE ( FALSE ) + THEN + ELSE + \ TRUE ABORT" USB device transaction error. (test-unit-ready)" + 5040 error" (USB) Device transaction error. (test-unit-ready)" + ABORT + THEN +; + +\ **************************************************** +\ multiple checks of 'test-unit-ready' with timeout +\ **************************************************** +: wait-for-unit-ready ( -- TRUE|FALSE ) + s" --> WAIT: test-unit-ready ... " usb-debug-print + d# 100 ( count ) \ up to 10 seconds + BEGIN ( count ) + dup 0> ( count flag ) + test-unit-ready \ dup IF 2b ELSE 2d THEN emit + not and ( count flag ) + WHILE + 1- ( count ) + d# 100 wait-proceed \ wait 100 ms + REPEAT ( count ) + 0= + IF + s" ** Device not ready ** " usb-debug-print + FALSE + ELSE + TRUE + THEN +; + + +\ ------------------------------------------------- +\ Method to 1. read sense data 2. analyse sesnse +\ data(pending) +\ ------------------------------------------------ + +: request-sense ( -- ) + s" request-sense: Command ready." usb-debug-print + command-buffer 1 12 80 lun scsi-length-request-sense + ( address tag transfer-len direction lun command-len ) + build-cbw +\ -scsi-supp- command-buffer SCSI-COMMAND-OFFSET + 12 ( address alloc-len ) +\ -scsi-supp- build-request-sense + + 12 command-buffer SCSI-COMMAND-OFFSET + ( alloc-len cdb ) + scsi-build-request-sense ( alloc-len cdb -- ) + + response-buffer 12 do-bulk-command + IF + s" Read Sense data successfully" usb-debug-print + \ response-buffer 12 dump cr \ dump the rsponsed message + ELSE + \ TRUE ABORT" USB device transaction error. (request-sense)" + 5040 error" (USB) Device transaction error. (request-sense)" + ABORT + THEN +; + +: start ( -- ) + command-buffer 1 0 80 lun scsi-length-start-stop-unit + ( address tag transfer-len direction lun command-len ) + build-cbw +\ -scsi-supp- command-buffer SCSI-COMMAND-OFFSET + ( address ) +\ -scsi-supp- build-start + + command-buffer SCSI-COMMAND-OFFSET + ( cdb ) + scsi-const-start scsi-build-start-stop-unit ( state# cdb -- ) + + response-buffer 0 do-bulk-command + IF + s" Start successfully" usb-debug-print + ELSE + \ TRUE ABORT" USB device transaction error. (start)" + 5040 error" (USB) Device transaction error. (start)" + ABORT + THEN +; + + +\ To transmit SCSI Stop command + +: stop ( -- ) + command-buffer 1 0 80 lun scsi-length-start-stop-unit + ( address tag transfer-len direction lun command-len ) + build-cbw +\ -scsi-supp- command-buffer SCSI-COMMAND-OFFSET + ( address ) +\ -scsi-supp- build-stop + + command-buffer SCSI-COMMAND-OFFSET + ( cdb ) + scsi-const-stop scsi-build-start-stop-unit ( state# cdb -- ) + + response-buffer 0 do-bulk-command + IF + s" Stop successfully" usb-debug-print + ELSE + \ TRUE ABORT" USB device transaction error. (stop)" + 5040 error" (USB) Device transaction error. (stop)" + ABORT + THEN +; + + +0 VALUE temp1 +0 VALUE temp2 +0 VALUE temp3 + + +\ ------------------------------------------------------------- +\ block device's seek +\ ------------------------------------------------------------- +\ if anything is wrong in the boot device, a seek-request can +\ occur that exceeds the limits of the device in the following +\ read-command. So checking is required and the appropriate +\ return-value has to be returned +\ Spec requires -1 if operation fails and 0 or 1 if it succeeds !! +\ ------------------------------------------------------------- + +: seek ( pos-lo pos-hi -- status ) + 2dup lxjoin max-block-num block-size * > + IF + ." ** Seek Error: pos too large (" + dup . over . ." -> " max-block-num block-size * . + ." ) ** " cr + -1 \ see spec-1275 page 183 + ELSE + s" seek" ihandle-deblocker @ $call-method + THEN +; + + +\ ------------------------------------------------------------- +\ block device's read +\ ------------------------------------------------------------- + +: read ( address length -- actual ) + s" read" ihandle-deblocker @ $call-method +; + + +\ ------------------------------------------------------------- +\ read-blocks to be used by deblocker +\ ------------------------------------------------------------- +: read-blocks ( address block# #blocks -- #read-blocks ) + 2dup + max-block-num > + IF + ." ** Requested block too large " + 2dup + ." (" .d ." -> " max-block-num .d + bs emit ." ) ... read aborted **" cr + nip nip \ leave #blocks on stack + ELSE + block-size * command-buffer ( address block# transfer-len command-buffer ) + 1 2 pick 80 lun 0c build-cbw ( address block# transfer-len ) + dup to temp1 ( address block# transfer-len ) + block-size / ( address block# #blocks ) + command-buffer ( address block# #blocks command-addr ) + SCSI-COMMAND-OFFSET + ( address block# #blocks cdb ) + scsi-build-read? ( block# #blocks cdb -- length ) + command-buffer 0e + c! \ update bCBWCBLength-field with resulting CDB length + temp1 ( address length ) + do-bulk-command + IF + s" Read data successfully" usb-debug-print + ELSE + \ TRUE ABORT" USB device transaction error. (read-blocks)" + 5040 error" (USB) Device transaction error. (read-blocks)" + ABORT + THEN + temp1 block-size / ( #read-blocks ) + THEN +; + +\ ------------------------------------------------ +\ To bring the the media to seekable and readable +\ condition. +\ ------------------------------------------------ + +d# 800 CONSTANT media-ready-retry + +: make-media-ready ( -- ) + s" usb-storage: make-media-ready" usb-debug-print + 0 flag ! + 0 count ! + BEGIN + flag @ 0= + WHILE + test-unit-ready IF + s" Media ready for access." usb-debug-print + 1 flag ! + ELSE + count @ 1 + count ! + count @ media-ready-retry = IF + 1 flag ! + 5000 error" (USB) Media or drive not ready for this blade." + ABORT + THEN + request-sense + response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true ) + IF + ffff00 AND \ remaining: sense-key ASC + CASE + 023a00 OF \ MEDIUM NOT PRESENT (02 3a 00) + 5010 error" (USB) No Media found! Check for the drawer/inserted media." + ABORT + ENDOF + + 020400 OF \ LOGICAL DRIVE NOT READY - INITIALIZATION REQUIRED + 5010 error" (USB) No Media found! Check for the drawer/inserted media." + ABORT + ENDOF + + 033000 OF \ CANNOT READ MEDIUM - UNKNOWN FORMAT + 5020 error" (USB) Unknown media format." + ABORT + ENDOF + ENDCASE + THEN + THEN + d# 10 ms \ wait maximum 10ms * 800 (=8s) + REPEAT + usb-debug-flag IF + ." make-media-ready finished after " + count @ decimal . hex ." tries." cr + THEN +; + +\ ------------------------------------------------ +\ read and show devices capacity +\ ------------------------------------------------ +: .showcap + space + test-unit-ready drop \ initial command + request-sense + response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true ) + IF + dup FFFF00 and 023a00 = ( sense-id flag ) + IF + uDOC-failure? + 023a02 = \ see sense-codes SPC-3 clause 4.5.6 + IF + ." Tray Open!" + ELSE + ." No Media" + THEN + ELSE ( sense-id ) + drop + wait-for-unit-ready + IF + read-capacity + response-buffer scsi-get-capacity-10 space .capacity-text + ELSE + request-sense + response-buffer scsi-get-sense-ID? ( addr -- false | sense-ID true ) + IF + dup ff0000 and 040000 = \ sense-code = 4 ? + IF + ." *HW-ERROR*" + uDOC-failure? + ELSE + dup FFFF00 and 023a00 = IF uDOC-failure? THEN + CASE ( sense-ID ) + \ see SPC-3 clause 4.5.6 + 023a00 OF ." No Media " ENDOF + 023a02 OF ." Tray Open! " ENDOF + dup OF ." ? " ENDOF + ENDCASE + THEN + THEN + THEN + THEN + ELSE + ." ?? " + THEN +; + + + +: init-dev-ready + test-unit-ready drop + 4 >r \ loop-counter + 0 0 + BEGIN + 2drop + request-sense + response-buffer scsi-get-sense-data ( ascq asc sense-key ) + 0<> r> 1- dup >r 0<> AND \ loop-counter or sense-key + WHILE + REPEAT + 2drop + r> drop +; + + + +scsi-close \ no further scsi words required + + +\ Set up the block-size of the device, using the READ CAPACITY command. +\ Note: Media must be ready (=> make-media-ready) or READ CAPACITY +\ might fail! + +: (init-block-size) + read-capacity + response-buffer l@ dup 0<> + IF + to max-block-num \ highest block-number + ELSE + -1 to max-block-num \ indeterminate + THEN + response-buffer 4 + + l@ to block-size + s" usb-storage: block-size=" block-size usb-debug-print-val +; + + +\ Standard OF methods + +: open ( -- TRUE ) + s" usb-storage: open" usb-debug-print + ihandle-bulk s" bulk" (open-package) + + make-media-ready + (init-block-size) \ Init block-size before opening the deblocker + + ihandle-deblocker s" deblocker" (open-package) + + s" disk-label" find-package IF ( phandle ) + usb-debug-flag IF ." my-args for disk-label = " my-args swap . . cr THEN + my-args rot interpose + THEN + TRUE ( TRUE ) +; + + +: close ( -- ) + ihandle-deblocker (close-package) + ihandle-bulk (close-package) +; + + +\ Set device name according to type + +: (init-device-name) ( -- ) + init-dev-ready + inquiry + response-buffer c@ + CASE + 1 OF .showcap s" tape" device-name ENDOF + 5 OF .showcap s" cdrom" device-name s" CDROM found" usb-debug-print ENDOF + 0 OF .showcap s" sbc-dev" device-name s" SBC Direct access device" usb-debug-print ENDOF + 7 OF .showcap s" optical" device-name s" Optical memory found" usb-debug-print ENDOF + 0E OF .showcap s" rbc-dev" device-name s" RBC direct acces device found" usb-debug-print ENDOF + \ dup OF s" storage" device-name ENDOF + ENDCASE +; + + +\ Initial device node setup + +: (initial-setup) + ihandle-bulk s" bulk" (open-package) + device-init + (init-device-name) + set-drive-alias + 200 to block-size \ Default block-size, will be overwritten in "open" + 10000 to max-transfer + + ihandle-bulk (close-package) +; + +(initial-setup) + diff --git a/slof/fs/usb/usb-support.fs b/slof/fs/usb/usb-support.fs new file mode 100644 index 0000000..08ff9bd --- /dev/null +++ b/slof/fs/usb/usb-support.fs @@ -0,0 +1,651 @@ +\ ***************************************************************************** +\ * 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 NEXT-TD + +0 VALUE num-tds +0 VALUE td-retire-count +0 VALUE saved-tail +0 VALUE poll-timer +VARIABLE controlxfer-cmd + +\ Allocate an ED and populate it + +: (ed-prepare) ( dir addr dlen setup-packet MPS ep-fun -- + FALSE | dir addr dlen ed-ptr setup-ptr ) + allocate-ed dup 0= IF ( dir addr dlen setup-packet MPS ep-fun ed-ptr ) + drop 3drop 2drop FALSE EXIT ( FALSE ) + THEN + TO temp1 ( dir addr dlen setup-packet MPS ep-fun ) + temp1 zero-out-an-ed-except-link ( dir addr dlen setup-packet MPS ep-fun ) + temp1 ed>eattr l@-le or temp1 ed>eattr l!-le ( dir addr dlen setup-ptr MPS ) + dup TO temp2 10 lshift temp1 ed>eattr l@-le or temp1 ed>eattr l!-le + ( dir addr dlen setup-packet-address ) + temp1 swap TRUE ( dir addr dlen ed-ptr setup-ptr TRUE ) +; + + +\ Allocate TD list + + +: (td-prepare) ( dir addr dlen ed-ptr setup-ptr -- + dir FALSE | dir addr dlen ed-ptr setup-ptr td-head td-tail ) + 2 pick ( dir addr dlen ed-ptr setup-ptr dlen ) + temp2 ( dir addr dlen ed-ptr setup-ptr dlen MPS ) + /mod ( dir addr dlen ed-ptr setup-ptr rem quo ) + swap 0<> IF ( dir addr dlen ed-ptr setup-ptr quo ) + 1+ + THEN + 2+ + dup TO num-tds ( dir addr dlen ed-ptr setup-ptr quo+2 ) + allocate-td-list dup 0= IF ( dir addr dlen ed-ptr setup-ptr quo+2 ) + 2drop ( dir addr dlen ed-ptr setup-ptr ) + drop ( dir addr dlen ed-ptr ) + free-ed ( dir addr dlen ) + 2drop ( dir ) + FALSE ( dir FALSE ) + EXIT + THEN TRUE +; + + +\ Fill in the ED structure completely. + + +: (td-ready) ( dir addr dlen ed-ptr setup-ptr td-head td-tail -- ) + ( dir addr dlen ed-ptr setup-ptr ) + 3 pick ( dir addr dlen ed-ptr setup-ptr td-head td-tail ed-ptr ) + tuck ( dir addr dlen ed-ptr setup-ptr td-head ed-ptr td-tail ed-ptr ) + ed>tdqtp l!-le ( dir addr dlen ed-ptr setup-ptr td-head ed-ptr ) + ed>tdqhp l!-le ( dir addr dlen ed-ptr setup-ptr ) + over ed>ned 0 swap l!-le ( dir addr dlen ed-ptr setup-ptr ) +; + + +\ Initialize the HEAD and TAIL TDs for SETUP and +\ STATUS phase respectively. + + +: (td-setup-status) ( dir addr dlen ed-ptr setup-ptr -- dir addr dlen ed-ptr ) + over ed>tdqhp l@-le ( dir addr dlen ed-ptr setup-ptr td-head ) + dup zero-out-a-td-except-link ( dir addr dlen ed-ptr setup-ptr td-head ) + dup td>tattr DATA0-TOGGLE CC-FRESH-TD or swap l!-le + ( dir addr dlen ed-ptr setup-ptr td-head ) + 2dup td>cbptr l!-le ( dir addr dlen ed-ptr setup-ptr td-head ) + 2dup td>bfrend swap STD-REQUEST-SETUP-SIZE 1- + swap l!-le + ( dir addr dlen ed-ptr setup-ptr td-head ) + 2drop ( dir addr dlen ed-ptr ) +; + +\ Initialize the TD TAIL pointer. + + +: (td-tailpointer) ( dir addr dlen ed-ptr -- dir addr dlen ed-ptr ) + dup ed>tdqtp l@-le ( dir addr dlen ed-ptr td-tail ) + dup zero-out-a-td-except-link ( dir addr dlen ed-ptr td-tail ) + dup td>tattr dup l@-le DATA1-TOGGLE CC-FRESH-TD or or swap l!-le + ( dir addr dlen ed-ptr td-tail ) + 4 pick 0= ( dir addr dlen ed-ptr td-tail flag ) + 3 pick 0<> ( dir addr dlen ed-ptr td-tail flag flag ) + and IF ( dir addr dlen ed-ptr td-tail ) + dup td>tattr dup l@-le TD-DP-OUT or swap l!-le + ( dir addr dlen ed-ptr td-tail ) + ELSE + dup td>tattr dup l@-le TD-DP-IN or swap l!-le + ( dir addr dlen ed-ptr td-tail ) + THEN + drop ( dir addr dlen ed-ptr ) +; + +\ Initialize the Data TDs. + + +: (td-data) ( dir addr dlen ed-ptr -- ed-ptr ) + -rot ( dir ed-ptr addr dlen ) + dup 0<> IF ( dir ed-ptr addr dlen ) + >r >r >r TO temp1 r> r> r> temp1 ( ed-ptr addr dlen dir ) + 3 pick ( ed-ptr addr dlen dir ed-ptr ) + ed>tdqhp l@-le td>ntd l@-le ( ed-ptr addr dlen dir td-datahead ) + 4 pick ( ed-ptr addr dlen dir td-datahead ed-ptr ) + td>tattr l@-le 10 rshift ( ed-ptr addr dlen dir td-head-data MPS ) + swap ( ed-ptr addr dlen dir MPS td-head-data ) + >r >r >r >r >r 1 r> r> r> r> r> + ( ed-ptr 1 addr dlen dir MPS td-head-data ) + >r >r 0= IF ( ed-ptr 1 addr dlen dir ) + OHCI-DP-IN ( ed-ptr 1 addr dlen dir OHCI-DP-IN ) + ELSE + OHCI-DP-OUT ( ed-ptr 1 addr dlen dir OHCI-DP-OUT ) + THEN + r> r> ( ed-ptr 1 addr dlen dir OHCI-DP- MPS td-head-data ) + fill-TD-list + ELSE + 2drop nip ( ed-ptr ) + THEN +; + + +\ Program the HC with the ed-ptr value and wait for status to +\ from the HC. +\ Free the ED and TDs associated with it. +\ PENDING: Above said. + +10 CONSTANT max-retire-td + +: (transfer-wait-for-doneq) ( ed-ptr -- TRUE | FALSE ) + dup ( ed-ptr ed-ptr ) + hcctrhead rl!-le ( ed-ptr ) + HC-enable-control-list-processing ( ed-ptr ) + 0 TO td-retire-count ( ed-ptr ) + 0 TO poll-timer ( ed-ptr ) + BEGIN + td-retire-count num-tds <> ( ed-ptr TRUE | FALSE ) + poll-timer max-retire-td < and ( ed-ptr TRUE | FALSE ) + WHILE + (HC-CHECK-WDH) ( ed-ptr ) + IF + hchccadneq l@-le find-td-list-tail-and-size nip ( ed-ptr n ) + td-retire-count + TO td-retire-count ( ed-ptr ) + hchccadneq l@-le dup ( ed-ptr done-td done-td ) + (td-list-status) ( ed-ptr done-td failed-td CCcode ) + IF + \ keep condition code of TD on return stack + dup >r + s" (transfer-wait-for-doneq: USB device communication error." + usb-debug-print ( ed-ptr done-td failed-td CCcode R: CCcode ) + dup 4 = swap dup 5 = rot or ( ed-ptr done-td failed-td CCcode R: CCcode ) + IF + max-retire-td TO poll-timer ( ed-ptr done-td failed-td CCcode R: CCcode ) + THEN + ( ed-ptr done-td failed-td CCcode R: CCcode ) + usb-debug-flag + IF + s" CC code ->" type . cr + s" Failing TD contents:" type cr display-td + ELSE + 2drop + THEN ( ed-ptr done-td R: CCcode ) + controlxfer-cmd @ GET-MAX-LUN = r> 4 = and + IF + s" (transfer-wait-for-doneq): GET-MAX-LUN ControlXfer STALLed" + usb-debug-print + \ Condition Code = 4 means that the device does not support multiple LUNS + \ see USB Massbulk 1.0 Standard + ELSE + drop + 5030 error" (USB) Device communication error." + ABORT + \ FIXME: ABORTing here might leave the HC in an unusable state. + \ We should maybe rather ABORT at the end of this Forth + \ word, when clean-up has been done (or not ABORT at all) + THEN + THEN ( ed-ptr done-td ) + (free-td-list) ( ed-ptr ) + 0 hchccadneq l!-le ( ed-ptr ) + (HC-ACK-WDH) \ TDs were written to DOne queue. ACK the HC. + THEN + poll-timer 1+ TO poll-timer + 4 ms \ longer 1 ms + REPEAT ( ed-ptr ) + disable-control-list-processing ( ed-ptr ) + td-retire-count num-tds <> ( ed-ptr ) + IF + dup display-descriptors ( ed-ptr ) + s" maximum of retire " usb-debug-print + THEN + free-ed + td-retire-count num-tds <> + IF + FALSE ( FALSE ) + ELSE + TRUE ( TRUE ) + THEN +; + + +\ COLON DEFINITION: controlxfer +\ INTERFACE FUNCTION + +\ ARGUMENTS: +\ (from the bottom OF stack) +\ 1. dir -- This is the direction OF data transfer associated with +\ the DATA STAGE OF the control xfer. +\ If there is no data transfer (argument dlen is zero) +\ THEN this argument DOes not matter, nonethless it has +\ to be passed. +\ A "0" represents an IN and "1" represents an "OUT". +\ 2. addr -- If therez a data stage associated with the transfer, +\ THEN, this argument holds the address OF the data buffer +\ 3. dlen -- This arg holds the length OF the data buffer discussed +\ in previous step (addr) +\ 4. setup-packet -- This holds the pointer to the setup packet that +\ will be transmitted during the SETUP stage OF +\ the control xfer. The function assumes the length +\ OF the status packet to be 8 bytes. +\ 5. MPS -- This is the MAX PACKET SIZE OF the endpoint. +\ 6. ep-fun -- This is the 11-bit value that holds the Endpoint and +\ the function address. bit 7 to bit 10 holds the Endpoint +\ address. Bits 0 to Bit 6 holds the Function Address. +\ The BIT numbering followed : The left most bit is referred +\ as bit 0. (not the one followed by PPC) +\ Bit 13 must be set for low-speed devices. + +\ RETURN VALUE: +\ Returns TRUE | FALSE depending on the success OF the transaction. + +\ ASSUMPTIONS: +\ 1. Function assumes that the setup packet is 8-bytes in length. +\ If in future, IF we need to add a new argument, we need to change +\ the function in lot OF places. + +\ RISKS: +\ 1. If for some reason, the USB controller DOes not retire all the TDs +\ THEN, the status checking part OF this "word" can spin forever. + + +: controlxfer ( dir addr dlen setup-packet MPS ep-fun -- TRUE | FALSE ) + 2 pick @ controlxfer-cmd ! + (ed-prepare) ( FALSE | dir addr dlen ed-ptr setup-ptr ) + invert IF FALSE EXIT THEN + (td-prepare) ( pt ed-type toggle buffer length mps head ) + invert IF FALSE EXIT THEN + (td-ready) ( dir addr dlen ed-ptr setup-ptr ) + (td-setup-status) ( dir addr dlen ed-ptr ) + (td-tailpointer) ( dir addr dlen ed-ptr ) + (td-data) ( ed-ptr ) + + + \ FIXME: + \ Clear the TAIL pointer in ED. This has got sthg to DO with how + \ the HC finds an EMPTY queue condition. Refer spec. + + + dup ed>tdqtp l@-le TO saved-tail ( ed-ptr ) + dup ed>tdqtp 0 swap l!-le ( ed-ptr ) + (transfer-wait-for-doneq) ( TRUE | FALSE ) +; + +0201000000000000 CONSTANT CLEARHALTFEATURE +0 VALUE endpt-num +0 VALUE usb-addr-contr-req +: control-std-clear-feature ( endpoint-nr usb-addr -- TRUE|FALSE ) + TO usb-addr-contr-req \ usb address + TO endpt-num \ endpoint number + CLEARHALTFEATURE setup-packet ! + endpt-num setup-packet 4 + c! \ endpoint number + 0 0 0 setup-packet DEFAULT-CONTROL-MPS usb-addr-contr-req controlxfer + ( TRUE|FALSE ) +; + +\ It resets the usb bulk-device +21FF000000000000 CONSTANT BULK-RESET +: control-std-bulk-reset ( usb-addr -- TRUE|FALSE ) + TO usb-addr-contr-req + BULK-RESET setup-packet ! + 0 0 0 setup-packet DEFAULT-CONTROL-MPS usb-addr-contr-req controlxfer + ( TRUE|FALSE ) +; + +: bulk-reset-recovery-procedure ( bulk-out-endp bulk-in-endp usb-addr -- ) + >r ( bulk-out-endp bulk-in-endp R: usb-addr ) + \ perform a bulk reset + r@ control-std-bulk-reset + IF s" bulk reset OK" + ELSE s" bulk reset failed" + THEN usb-debug-print + + \ clear bulk-in endpoint ( bulk-out-endp bulk-in-endp R: usb-addr ) + 80 or r@ control-std-clear-feature + IF s" control-std-clear IN endpoint OK" + ELSE s" control-std-clear-IN endpoint failed" + THEN usb-debug-print + + \ clear bulk-out endpoint ( bulk-out-endp R: usb-addr ) + r@ control-std-clear-feature + IF s" control-std-clear OUT endpoint OK" + ELSE s" control-std-clear-OUT endpoint failed" + THEN usb-debug-print + r> drop +; + +0 VALUE saved-rw-ed +0 VALUE num-rw-tds +0 VALUE num-rw-retired-tds +0 VALUE saved-rw-start-toggle +0 VALUE saved-list-type + +\ Allocate an ED and populate what you can. + + +: (ed-prepare-rw) + ( pt ed-type toggle buffer length mps address ed-ptr -- + FALSE | pt ed-type toggle buffer length mps ) + allocate-ed dup 0= IF + ( pt ed-type toggle buffer length mps address ed-ptr ) + drop 2drop 2drop 2drop drop + saved-rw-start-toggle FALSE EXIT ( toggle FALSE ) + THEN + TO saved-rw-ed ( pt ed-type toggle buffer length mps address ) + saved-rw-ed zero-out-an-ed-except-link + ( pt ed-type toggle buffer length mps address ) + saved-rw-ed ed>eattr l!-le ( pt ed-type toggle buffer length mps ) + dup 10 lshift saved-rw-ed ed>eattr l@-le or + ( pt ed-type toggle buffer length mps mps~ ) + saved-rw-ed ed>eattr l!-le TRUE ( pt ed-type toggle buffer length mps TRUE ) +; + + +\ Allocate TD List + + +: (td-prepare-rw) + ( pt ed-type toggle buffer length mps -- + FALSE | pt ed-type toggle buffer length mps head ) + 2dup ( pt ed-type toggle buffer length mps length mps ) + /mod ( pt ed-type toggle buffer length mps num-tds rem ) + swap 0<> IF ( pt ed-type toggle buffer length mps num-tds ) + 1+ ( pt ed-type toggle buffer length mps num-tds+1 ) + THEN + dup TO num-rw-tds ( pt ed-type toggle buffer length mps num-tds ) + allocate-td-list ( pt ed-type toggle buffer length mps head tail ) + dup 0= IF + 2drop 2drop 2drop 2drop + saved-rw-ed free-ed + ." rw-endpoint: TD list allocation failed" cr + saved-rw-start-toggle FALSE ( FALSE ) + EXIT + THEN + drop TRUE ( pt ed-type toggle buffer length mps head TRUE ) +; + + +\ Populate TD list with data buffers and toggle info. + + +: (td-data-rw) + ( pt ed-type toggle buffer length mps head -- FALSE | pt et head ) + 6 pick ( pt ed-type toggle buffer length mps head pt ) + FALSE TO case-failed CASE + 0 OF OHCI-DP-IN ENDOF + 1 OF OHCI-DP-OUT ENDOF + 2 OF OHCI-DP-SETUP ENDOF + dup OF TRUE TO case-failed + ." rw-endpoint: Invalid Packet Type!" cr + ENDOF + ENDCASE ( pt ed-type toggle buffer length mps head dp ) + case-failed IF + saved-rw-ed free-ed ( pt ed-type toggle buffer length mps head dp ) + drop (free-td-list) ( pt ed-type toggle buffer length mps head ) + 2drop 2drop 2drop + saved-rw-start-toggle FALSE ( FALSE ) + EXIT ( FALSE ) + THEN + -rot ( pt ed-type toggle buffer length dp mps head ) + dup >r ( pt ed-type toggle buffer length dp mps head ) + fill-TD-list r> TRUE ( pt et head TRUE ) +; + + +\ Enqueue the ED with the appropriate list + + +: (ed-ready-rw) ( pt et -- - | toggle FALSE ) + nip ( et ) + FALSE TO case-failed CASE + 0 OF \ Control List. Queue the ED to control list + 0 TO saved-list-type + saved-rw-ed hcctrhead rl!-le + HC-enable-control-list-processing + ENDOF + 1 OF \ Bulk List. Queue the ED to bulk list + 1 TO saved-list-type + saved-rw-ed hcbulkhead rl!-le + HC-enable-bulk-list-processing + ENDOF + 2 OF \ Interrupt List. + 2 TO saved-list-type + saved-rw-ed hchccareg rl@-le rl!-le + HC-enable-interrupt-list-processing + ENDOF + dup OF + saved-rw-ed ed>tdqhp l@-le (free-td-list) + saved-rw-ed free-ed + TRUE TO case-failed + ENDOF + ENDCASE + case-failed IF + saved-rw-start-toggle FALSE ( toggle FALSE ) + EXIT + THEN + TRUE ( TRUE ) +; + +\ Wait for TDs to return to the Done Q. + +: (wait-td-retire) ( -- ) + 0 TO num-rw-retired-tds + FALSE TO while-failed + BEGIN + num-rw-retired-tds num-rw-tds < ( TRUE | FALSE ) + while-failed FALSE = and ( TRUE | FALSE ) + WHILE + d# 5000 (wait-for-done-q) ( TD-list TRUE|FALSE ) + IF + dup find-td-list-tail-and-size nip ( td-list size ) + num-rw-retired-tds + TO num-rw-retired-tds ( td-list ) + dup (td-list-status) ( td-list failed-TD CC ) + IF + dup 4 = + IF + saved-list-type + CASE + 0 OF + 0 0 control-std-clear-feature + s" clear feature " usb-debug-print + ENDOF + 1 OF \ clean bulk stalled + s" clear bulk when stalled " usb-debug-print + disable-bulk-list-processing \ disable procesing + saved-rw-ed ed>eattr l@-le dup \ extract + 780 and 7 rshift 80 or \ endpoint and + swap 7f and \ usb addr + control-std-clear-feature + ENDOF + 2 OF + 0 saved-rw-ed ed>eattr l@-le + control-std-clear-feature + ENDOF + dup OF + s" unknown status " usb-debug-print + ENDOF + ENDCASE + ELSE ( td-list failed-TD CC ) + ." TD failed " 5b emit .s 5d emit cr + 5040 error" (USB) device transaction error (wait-td-retire)." + ABORT + THEN + 2drop drop + TRUE TO while-failed \ transaction failed + NEXT-TD 0<> \ clean the TD if we + IF + NEXT-TD (free-td-list) \ had a stalled + THEN + THEN + (free-td-list) + ELSE + drop \ drop td-list pointer + scan-time? IF 2e emit THEN \ show proceeding dots + TRUE TO while-failed + s" time out wait for done" usb-debug-print + 20 ms \ wait for bad device + THEN + REPEAT +; + + +\ Process retired TDs + + +: (process-retired-td) ( -- TRUE | FALSE ) + saved-list-type CASE + 0 OF disable-control-list-processing ENDOF + 1 OF disable-bulk-list-processing ENDOF + 2 OF disable-interrupt-list-processing ENDOF + ENDCASE + saved-rw-ed ed>tdqhp l@-le 2 and 0<> IF + 1 + s" retired 1" usb-debug-print + ELSE + 0 + s" retired 0" usb-debug-print + THEN + \ s" retired " usb-debug-print-val + WHILE-failed IF + FALSE ( FALSE ) + ELSE + TRUE ( TRUE ) + THEN + saved-rw-ed free-ed +; + + +\ (DO-rw-endpoint): T1 12 80 0 0chis method is an privately visible function +\ to be used by the "rw-endpoint" the required +\ number OF times based on the actual length +\ to be transferred + +\ Arguments: +\ pt: Packet type +\ 0 -> IN +\ 1 -> OUT +\ 2 -> SETUP +\ et: Endpoint type +\ 0 -> Control +\ 1 -> Bulk +\ toggle: Starting toggle for this transfer +\ buffer length: Data buffer associated with the transfer limited +\ accordingly by the "rw-endpoint" method to the +\ value OF max packet size +\ mps: Max Packet Size. +\ address: Address OF endpoint. 11-bit address. The lower 7-bits represent +\ the USB addres and the upper 4-bits represent the Endpoint +\ number. + + + +: (do-rw-endpoint) + ( pt ed-type toggle buffer length mps address -- toggle TRUE|toggle FALSE ) + 4 pick ( pt ed-type toggle buffer length mps address toggle ) + TO saved-rw-start-toggle ( pt ed-type toggle buffer length mps address ) + (ed-prepare-rw) ( FALSE | pt ed-type toggle buffer length mps ) + invert IF FALSE EXIT THEN + (td-prepare-rw) ( FALSE | pt ed-type toggle buffer length mps head ) + invert IF FALSE EXIT THEN + (td-data-rw) ( FALSE | pt et head ) + invert IF FALSE EXIT THEN + saved-rw-ed ed>tdqhp l!-le ( pt et ) + saved-rw-ed ed>tdqhp l@-le td>ntd l@-le TO NEXT-TD \ save for a stalled + (ed-ready-rw) + invert IF FALSE EXIT THEN + (wait-td-retire) + (process-retired-td) ( TRUE | FALSE ) +; + + +\ rw-endpoint: The method is an externally visible method to be exported +\ to the child nodes. It uses the internal method +\ "(DO-rw-endpoint)", the required number OF times based on the +\ actual length OF transfer, so that the limitataion OF MAX-TDS +\ DO not hinder the transfer. + +\ Arguments: +\ pt: Packet type +\ 0 -> IN +\ 1 -> OUT +\ 2 -> SETUP +\ et: Endpoint type +\ 0 -> Control +\ 1 -> Bulk +\ toggle: Starting toggle for this transfer +\ buffer length: Data buffer associated with the transfer +\ mps: Max Packet Size. +\ address: Address OF endpoint. 11-bit address. The lower 7-bits represent +\ the USB addres and the upper 4-bits represent the Endpoint +\ number. + + +0 VALUE transfer-len +0 VALUE mps-current +0 VALUE addr-current +0 VALUE usb-addr +0 VALUE toggle-current +0 VALUE type-current +0 VALUE pt-current +0 VALUE read-status +0 VALUE counter +0 VALUE residue + + +: rw-endpoint + ( pt ed-type toggle buffer length mps address -- ) + ( toggle TRUE |toggle FALSE ) + + \ a single transfer descriptor can point to a buffer OF + \ 8192 bytes a block on the CDROM has 2048 bytes + \ but a single transfer is constrained by the MPS + + 2 pick TO transfer-len ( pt ed-type toggle buffer length mps address ) + 1 pick TO mps-current ( pt ed-type toggle buffer length mps address ) + TRUE TO read-status ( pt ed-type toggle buffer length mps address ) + transfer-len mps-current num-free-tds * <= IF + (do-rw-endpoint) ( toggle TRUE | toggle FALSE ) + TO read-status ( toggle ) + TO toggle-current + ELSE + TO usb-addr ( pt ed-type toggle buffer length mps ) + 2drop ( pt ed-type toggle buffer ) + TO addr-current ( pt ed-type toggle ) + TO toggle-current ( pt ed-type ) + TO type-current ( pt ) + TO pt-current + transfer-len mps-current num-free-tds * /mod ( residue count ) + ( remainder=residue quotient=count ) + TO counter ( residue ) + TO residue + mps-current num-free-tds * TO transfer-len BEGIN + counter 0 > ( TRUE | FALSE ) + read-status TRUE = and ( TRUE | FALSE ) + WHILE + pt-current type-current toggle-current ( pt ed-type toggle ) + addr-current transfer-len ( pt ed-type toggle buffer length ) + mps-current ( pt ed-type toggle buffer length mps ) + usb-addr (do-rw-endpoint) ( toggle TRUE | toggle FALSE ) + TO read-status ( toggle ) + TO toggle-current + addr-current transfer-len + TO addr-current + counter 1- TO counter + REPEAT + residue 0<> ( TRUE |FALSE ) + read-status TRUE = and IF + residue TO transfer-len + pt-current type-current toggle-current ( pt ed-type toggle ) + addr-current transfer-len ( pt ed-type toggle buffer length ) + mps-current ( pt ed-type toggle buffer length mps ) + usb-addr (do-rw-endpoint) ( toggle TRUE | toggle FALSE ) + TO read-status + TO toggle-current + THEN + THEN + read-status invert IF + THEN + toggle-current ( toggle ) + read-status ( TRUE | FALSE ) +; diff --git a/slof/fs/vpd-bootlist.fs b/slof/fs/vpd-bootlist.fs new file mode 100644 index 0000000..5a08215 --- /dev/null +++ b/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/slof/fs/xmodem.fs b/slof/fs/xmodem.fs new file mode 100644 index 0000000..a111708 --- /dev/null +++ b/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 + load-base (xmodem-load) +; diff --git a/slof/lowmem.S b/slof/lowmem.S new file mode 100644 index 0000000..3f99320 --- /dev/null +++ b/slof/lowmem.S @@ -0,0 +1,67 @@ +/****************************************************************************** + * 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 */ + ld r3,XVECT_S_HANDLER(0) + mfspr r0, PIR + cmpwi r0, 0 + bne 0f + 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/slof/ofw.S b/slof/ofw.S new file mode 100644 index 0000000..a717314 --- /dev/null +++ b/slof/ofw.S @@ -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 + *****************************************************************************/ + +#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 */ + + /* fill in handler address */ + + /* this only works if paflof is running below 4GB */ + lis r3, _slof_text@h + ori r3, r3, _slof_text@l + ld r3, 0(r3) + std r3, XVECT_M_HANDLER(0) + + /* GO! */ + ba 0x100 diff --git a/slof/paflof.c b/slof/paflof.c new file mode 100644 index 0000000..343d623 --- /dev/null +++ b/slof/paflof.c @@ -0,0 +1,106 @@ +/****************************************************************************** + * 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 ISTR(TARG,h) + +#define LAST_ELEMENT(x) x[sizeof x / sizeof x[0] - 1] + +unsigned long fdt_start; +unsigned long romfs_base; +unsigned long epapr_magic; +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/slof/paflof.h b/slof/paflof.h new file mode 100644 index 0000000..885c948 --- /dev/null +++ b/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/slof/ppc64.c b/slof/ppc64.c new file mode 100644 index 0000000..8ad828c --- /dev/null +++ b/slof/ppc64.c @@ -0,0 +1,108 @@ +/****************************************************************************** + * 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); + + +static unsigned long __attribute__((noinline)) +call_c(cell arg0, cell arg1, cell arg2, cell entry) +{ + register unsigned long r3 asm("r3") = arg0.u; + register unsigned long r4 asm("r4") = arg1.u; + register unsigned long r5 asm("r5") = arg2.u; + register unsigned long r6 = entry.u ; + + asm volatile("mflr 31 ; mtctr %4 ; bctrl ; mtlr 31" + : "=r" (r3) + : "r" (r3), "r" (r4), "r" (r5), "r" (r6) + : "ctr", "r6", "r7", "r8", "r9", "r10", "r11", + "r12", "r13", "r31"); + + return r3; +} + +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/slof/ppc64.code b/slof/ppc64.code new file mode 100644 index 0000000..620446c --- /dev/null +++ b/slof/ppc64.code @@ -0,0 +1,263 @@ +/****************************************************************************** + * 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. + +// The I/O accesses themselves. +PRIM(RB_X40) GET_CHAR1; SET_CI; GET_CHAR2; CLR_CI; GET_CHAR3; MIRP +PRIM(RB_X21) PUT_CHAR1; SET_CI; PUT_CHAR2; CLR_CI; MIRP +PRIM(RW_X40) GET_WORD1; SET_CI; GET_WORD2; CLR_CI; GET_WORD3; MIRP +PRIM(RW_X21) PUT_WORD1; SET_CI; PUT_WORD2; CLR_CI; MIRP +PRIM(RL_X40) GET_LONG1; SET_CI; GET_LONG2; CLR_CI; GET_LONG3; MIRP +PRIM(RL_X21) PUT_LONG1; SET_CI; PUT_LONG2; CLR_CI; MIRP +PRIM(RX_X40) GET_XONG1; SET_CI; GET_XONG2; CLR_CI; GET_XONG3; MIRP +PRIM(RX_X21) PUT_XONG1; SET_CI; PUT_XONG2; CLR_CI; MIRP + +// 970-specific CPU registers. +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 diff --git a/slof/ppc64.h b/slof/ppc64.h new file mode 100644 index 0000000..2e9d90c --- /dev/null +++ b/slof/ppc64.h @@ -0,0 +1,36 @@ +/****************************************************************************** + * 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 + +#define SET_CI set_ci() +#define CLR_CI clr_ci() + +// 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/slof/ppc64.in b/slof/ppc64.in new file mode 100644 index 0000000..56ab66d --- /dev/null +++ b/slof/ppc64.in @@ -0,0 +1,103 @@ +/****************************************************************************** + * 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. + +// I/O accesses. +cod(RB@) +cod(RB!) +cod(RW@) +cod(RW!) +cod(RL@) +cod(RL!) +cod(RX@) +cod(RX!) + +// 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) + + +// 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/slof/prep.h b/slof/prep.h new file mode 100644 index 0000000..03950ba --- /dev/null +++ b/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/slof/prim.code b/slof/prim.code new file mode 100644 index 0000000..d1ac61f --- /dev/null +++ b/slof/prim.code @@ -0,0 +1,634 @@ +/****************************************************************************** + * 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("#### " #name); \ + 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 + +// 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 + +// 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; + } + + + + +// 3.1 +#define _FWMOVE(s, d, size, t) \ + { t *s1=(t *)s, *d1=(t *)d; \ + while (size > 0) { *d1++ = *s1++; size -= sizeof(t); } } + +#define _BWMOVE(s, d, size, t) { \ + t *s1=(t *)((char *)s+size), *d1=(t *)((char *)d+size); \ + while (size > 0) { *--d1 = *--s1; size -= sizeof(t); } \ +} + +#define _FWOVERLAP(s, d, size) ((d >= s) && ((type_u)d < ((type_u)s + size))) + +#define _MOVE(s, d, size, t) if _FWOVERLAP(s, d, size) _BWMOVE(s, d, size, t) else _FWMOVE(s, d, size, t) + +#define _FASTMOVE(s, d, size) \ + switch (((type_u)s | (type_u)d | size) & (sizeof(type_u)-1)) { \ + case 0: _MOVE(s, d, size, type_u); break; \ + case sizeof(type_l): _MOVE(s, d, size, type_l); break; \ + case sizeof(type_w): _MOVE(s, d, size, type_w); break; \ + default: _MOVE(s, d, size, type_c); break; \ + } + +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; + } + +// Device IO block data helpers +#define _FWRMOVE(s, d, size, t) \ + { t *s1=(t *)s, *d1=(t *)d; SET_CI; \ + while (size > 0) { *d1++ = *s1++; size -= sizeof(t); } \ + CLR_CI; \ +} + +#define _BWRMOVE(s, d, size, t) { \ + t *s1=(t *)((char *)s+size), *d1=(t *)((char *)d+size); SET_CI; \ + while (size > 0) { *--d1 = *--s1; size -= sizeof(t); } \ + CLR_CI; \ +} + +#define _RMOVE(s, d, size, t) if _FWOVERLAP(s, d, size) _BWRMOVE(s, d, size, t) else _FWRMOVE(s, d, size, t) + +#define _FASTRMOVE(s, d, size) \ + switch (((type_u)s | (type_u)d | size) & (sizeof(type_u)-1)) { \ + case 0: _RMOVE(s, d, size, type_u); break; \ + case sizeof(type_l): _RMOVE(s, d, size, type_l); break; \ + case sizeof(type_w): _RMOVE(s, d, size, type_w); break; \ + default: _RMOVE(s, d, size, type_c); break; \ + } + +code_RMOVE: + { + type_u size = ((dp--)->u); + type_u *d = (type_u *)((dp--)->u); + type_u *s = (type_u *)((dp--)->u); + + _FASTRMOVE(s, d, size); + NEXT; + } + + +// 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/slof/prim.in b/slof/prim.in new file mode 100644 index 0000000..b14a867 --- /dev/null +++ b/slof/prim.in @@ -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 + *****************************************************************************/ + +// +// 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(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) + +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(RMOVE64) +cod(RMOVE) +cod(ZCOUNT) +con(HASH-SIZE HASHSIZE) +cod(HASH) +cod(CLEAN-HASH) +cod(HASH-TABLE) diff --git a/slof/ref.pl b/slof/ref.pl new file mode 100644 index 0000000..b21f139 --- /dev/null +++ b/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/slof/types.h b/slof/types.h new file mode 100644 index 0000000..e347cc3 --- /dev/null +++ b/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 */ |