diff options
Diffstat (limited to 'slof')
102 files changed, 17824 insertions, 944 deletions
diff --git a/slof/Makefile.inc b/slof/Makefile.inc new file mode 100644 index 0000000..57bfce3 --- /dev/null +++ b/slof/Makefile.inc @@ -0,0 +1,161 @@ +# ***************************************************************************** +# * Copyright (c) 2004, 2007 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 > 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 $@ + +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 + +slof.bin: paflof + $(OBJCOPY) -Obinary paflof $@ + +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 slof.bin 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 index 133cb8b..44d710b 100644 --- a/slof/OF.lds +++ b/slof/OF.lds @@ -1,29 +1,62 @@ -/* ============================================================================= */ -/* * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 { - .slof.vectors 0 : { *(.slof.vectors) } + . = 0xE100000; + _slof_start = .; + . = 0x0E10C000; + .slof.loader : { *(.slof.loader) } + . = 0x0E110000; /* + SIZEOF_HEADERS; */ + _slof_text = .; + _start_OF = .; +/* .rela : { *(.rela.*) } */ + .text : { *(.entry_text) *(.text) } = 0x60000000 + _slof_text_end = .; + . = ALIGN(8); + _slof_text_size = (_slof_text_end - _slof_text); - .slof.text 0x1110000 : { *(.text) } = 0x60000000 - - .slof.data 0x1120000 : { - KEEP (*(.opd)) - . = ALIGN(8); + . = ALIGN(0x1000); + .opd : + { + _slof_data = .; + *(.opd) + } + . = ALIGN(8); + .got : + { *(.got .toc) - *(.data .data.*) } + .data : { *(.rodata .rodata.*) *(.data .data.*) } + .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); + _slof_here_start = .; } diff --git a/slof/default-font.c b/slof/default-font.c new file mode 100644 index 0000000..f3cfcd2 --- /dev/null +++ b/slof/default-font.c @@ -0,0 +1,1653 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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 index 7b9dc82..3ab62da 100644 --- a/slof/engine.in +++ b/slof/engine.in @@ -1,13 +1,15 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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 (c) 2004, 2005 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 // ============================================================================ @@ -24,7 +26,6 @@ // 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)) @@ -38,8 +39,10 @@ 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) @@ -47,19 +50,23 @@ con(D#10 0x0a) 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+) @@ -91,6 +98,10 @@ 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) // Arithmetic. @@ -154,7 +165,7 @@ 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> 0BRANCH(1) DNEGATE) +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) @@ -173,14 +184,22 @@ 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) @@ -194,16 +213,19 @@ col(UNLOOP R> R> R> 2DROP >R) // Memory accesses. col(+! TUCK @ + SWAP !) -col(COMP 0 DO?DO(27) OVER I + C@ OVER I + C@ 2DUP < 0BRANCH(6) 2DROP UNLOOP 2DROP LIT(-1) EXIT > 0BRANCH(4) UNLOOP 2DROP 1 EXIT DOLOOP(-27) 2DROP 0) +cod(COMP) col(OFF FALSE SWAP !) col(ON TRUE SWAP !) col(<W@ W@ DUP LIT(0x8000) >= 0BRANCH(3) LIT(0x10000) -) -col(2@ DUP @ SWAP CELL+ @) -col(2! DUP >R CELL+ ! R> !) +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(FILL -ROT BOUNDS DO?DO(5) DUP I C! DOLOOP(-5) DROP) +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) @@ -244,6 +266,7 @@ 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) + ) @@ -286,7 +309,7 @@ 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 0 DO?DO(8) DEPTH I - 1- PICK . DOLOOP(-8)) +col(.S DEPTH DUP 0< 0BRANCH(2) DROP EXIT 0 DO?DO(8) DEPTH I - 1- PICK . DOLOOP(-8)) col(? @ .) @@ -302,6 +325,7 @@ 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) @@ -313,23 +337,24 @@ 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. -// LASTWORD must be the last thing in our dictionary! -extern cell xt_LASTWORD[]; - -raw(FORTH-WORDLIST DODOES _A(xt_NOOP+3) _A(0) _A(xt_LASTWORD)) - // +4 for 32-bit, +3 for 64-bit - -raw(CURRENT DOVAL _A(xt_FORTH_X2d_WORDLIST+5)) +// 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+) -raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+5) _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)) +// 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 -raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+4)) - // +6 for 32-bit, +4 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+) @@ -343,8 +368,9 @@ dfr((REVEAL)) col(HEADER ALIGN HERE LAST @ , LATEST ! 0 C, STRING, ALIGN) col(REVEAL LATEST @ LINK>NAME NAME>STRING (REVEAL) LATEST @ LAST !) + // Finding words. -col(STRING=CI >R SWAP DUP R> <> 0BRANCH(3) 3DROP FALSE EXIT CHARS BOUNDS DO?DO(18) DUP C@ UPC I C@ UPC <> 0BRANCH(4) DROP UNLOOP FALSE EXIT CHAR+ 1 CHARS DO+LOOP(-18) DROP TRUE) +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) @@ -356,16 +382,15 @@ con('IMMEDIATE 1) col(IMMEDIATE? 'IMMEDIATE AND 0<>) col(IMMEDIATE LAST @ CELL+ DUP C@ 'IMMEDIATE OR SWAP C!) -// Utility -- list all words in compilation wordlist. -col(WORDS LAST @ ?DUP 0BRANCH(9) DUP CELL+ CHAR+ COUNT TYPE SPACE @ BRANCH(-12)) - // 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) -col(POCKET LIT(POCKETSIZE) WHICHPOCKET @ * POCKETS + 1 WHICHPOCKET @ - WHICHPOCKET !) +// We reserved 0x1000 for the pockets. So we have 16 pockets a 0x100 +col(POCKET POCKETS WHICHPOCKET @ LIT(POCKETSIZE) * + WHICHPOCKET @ 1 + DUP LIT(16) = 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. @@ -376,44 +401,54 @@ imm(\ LINEFEED PARSE 2DROP) // The compiler infrastructure. var(STATE 0) imm([ STATE OFF) -col(] STATE ON) +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(; DOTICK EXIT COMPILE, REVEAL [) +imm(; ?COMP DOTICK SEMICOLON COMPILE, REVEAL [) // Compiling strings. -imm(C" LIT('"') PARSE DOTICK SLITERAL COMPILE, DUP C, BOUNDS DO?DO(5) I C@ C, DOLOOP(-5) ALIGN) +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(." S" DOTICK TYPE COMPILE,) +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 DOTICK DOBRANCH COMPILE, HERE 0 COMPILE,) -imm(IF DOTICK DO0BRANCH COMPILE, HERE 0 COMPILE,) -imm(THEN RESOLVE-ORIG) -imm(ELSE DOTICK DOBRANCH COMPILE, HERE 0 COMPILE, SWAP RESOLVE-ORIG) -imm(CASE 0) -imm(ENDCASE DOTICK DROP COMPILE, ?DUP 0BRANCH(5) 1- SWAP THEN BRANCH(-8)) -imm(OF 1+ >R DOTICK OVER COMPILE, DOTICK = COMPILE, IF DOTICK DROP COMPILE, R>) -imm(ENDOF >R ELSE R>) +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 HERE) -imm(AGAIN DOTICK DOBRANCH COMPILE, RESOLVE-DEST) -imm(UNTIL DOTICK DO0BRANCH COMPILE, RESOLVE-DEST) -imm(WHILE IF SWAP) -imm(REPEAT AGAIN THEN) +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 LEAVES @ HERE DOTICK DODO COMPILE, 0 LEAVES !) -imm(?DO LEAVES @ DOTICK DODO?DO COMPILE, HERE HERE LEAVES ! 0 COMPILE,) -imm(LOOP DOTICK DODOLOOP COMPILE, RESOLVE-LOOP) -imm(+LOOP DOTICK DODO+LOOP COMPILE, RESOLVE-LOOP) -imm(LEAVE DOTICK DODOLEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,) -imm(?LEAVE DOTICK DODO?LEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,) +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) @@ -423,7 +458,14 @@ col(RESTORE-SOURCE R> R> >IN ! R> SPAN ! R> DOTO SOURCE-ID R> #IB ! R> DOTO IB > str(OK-STR "ok") str(ABORTED-STR "Aborted") str(EXCEPTION-STR "Exception #") -col(PRINT-STATUS SPACE DUP 0= 0BRANCH(4) 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(5) DOTICK EXCEPTION-STR COUNT TYPE . CR) +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) @@ -431,7 +473,7 @@ col(INTERPRET-WORD 2DUP $FIND 0BRANCH(5) DROP NIP NIP EXECUTE EXIT 2DUP $NUMBER 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 INTERPRET RESTORE-SOURCE) +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. @@ -466,11 +508,11 @@ 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,) -col(COMPILE R> CELL+ DUP @ COMPILE, >R) 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) @@ -488,3 +530,8 @@ 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 index 86e7680..f57ddab 100644 --- a/slof/entry.S +++ b/slof/entry.S @@ -1,89 +1,91 @@ -# ============================================================================= -# * Copyright (c) 2004, 2005 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 entry points into the engine, as well as everything else in low memory. -# - - .section ".slof.vectors","ax" - - . = 0 - - .asciz "SLOF, the SlimLine Open Firmware" - - - # - # The reset exception. +/****************************************************************************** + * Copyright (c) 2004, 2007 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> + # - - . = 0x0100 - mtsprg 0,0 - li 0,0x0100 - b handler - - - + # The generic exception code. # - # All other exceptions. + # Enter with GPR0 = vector, SPRG0 = saved GPR0 # - .irp i, 0x0200,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 - . = \i - mtsprg 0,0 ; li 0,\i ; b handler - .endr - + .section ".entry_text" +the_handler: + .quad handler - # - # The generic exception code. - # - # Enter with GPR0 = vector, SPRG0 = saved GPR0. - # +eregs: + .quad _slof_start # XXX make configurable at startup time + # should stay page aligned! - . = 0x3000 handler: mtsprg 1,1 # SPRG1 = saved GPR1 - lis 1,0x0110 # GPR1 = address of register save area + 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 - mr 3,0 # GPR3 = vector - - mfsprg 0,0 ; std 0,0(1) # save GPR0 - mfsprg 0,1 ; std 0,8(1) # save GPR1 - - mfcr 0 ; std 0,0x100(1) - mfxer 0 ; std 0,0x108(1) - mflr 0 ; std 0,0x110(1) - mfctr 0 ; 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 - - addi 1,1,0x7000 ; li 0,0 ; stdu 0,-16(1) # set up stack - lis 2,engine@ha ; ld 2,8+engine@l(2) # set up TOC pointer - b .engine # ...and go! - + mr 3,0 // GPR3 = vector + + mfsprg 0,0 + std 0,0(1) # save GPR0 + mfsprg 0,1 + std 0,8(1) # save GPR1 + + cmpwi r3, 0x900 # Decrementer interrupt + bne 0f + mfdec r4 # Save old value of decrementer as reason + lis r0,0x7fff # Set decrementer to highest value + mtdec r0 +0: + cmpwi r3, 0x500 # External interrupt + bne 0f + LOAD64(r4, 0x20000508408) + ld r4, 0(r4) # Read destructive interrupt reason +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 + + addi 1,1,0x7000 + li 0,0 + stdu 0,-0x10(1) + stdu 1,-0x100(1) # set up stack + + 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! @@ -92,7 +94,7 @@ handler: # swap_ci_regs: - lis 8,0x0110 + lis 8,_slof_start@ha addi 8,8,0x0400 .irp i, 1,2,3,4,5,6,7, \ @@ -102,11 +104,19 @@ swap_ci_regs: 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 + 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. @@ -121,8 +131,11 @@ client_entry_point: .type .client_entry_point,@function .globl .client_entry_point .client_entry_point: - mflr 4 ; bl swap_ci_regs ; mtlr 4 ; li 3,0 ; blr - + mflr 4 + bl swap_ci_regs # swap regs + mtlr 4 + li 3, 0 # client call + blr # # Start the client. @@ -137,59 +150,12 @@ call_client: .type .call_client,@function .globl .call_client -.call_client: # called with GPR3 = address, returns GPR3 - mflr 4 ; mtctr 3 ; bl swap_ci_regs ; bctrl - bl swap_ci_regs ; mtlr 4 ; li 3,-1 ; blr - - - .globl flush_cache - .section ".opd","aw" - .align 3 -flush_cache: - .quad .flush_cache,.TOC.@tocbase,0 - .previous - .type .flush_cache,@function - .globl .flush_cache -.flush_cache: # flush at GPR3 size GPR4 - add 4,4,3 - addi 4,4,127 - rlwinm 3,3,0,0,24 - rlwinm 4,4,0,0,24 - sub 4,4,3 - srwi 4,4,7 - mtctr 4 -0: - dcbst 0,3 - sync - icbi 0,3 - sync - isync - addi 3,3,128 - bdnz 0b - +.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 - - - # - # This is where the secondary CPUs sit and wait. - # - - . = 0x3f00 -slaveloop: - lis 0,10 - mtctr 0 - bdnz $ # do some waiting, to prevent flooding the buses - lwz 0,0x3f40(0) - and. 0,0,0 - beq $-20 # wait for our flag - - lwz 0,0x3f80(0) - lwz 3,0x3fc0(0) - mtctr 0 - bctr # jump to specified address, with specified GPR3 - - - - -. = 0x3fff -.byte 0x36 # to fill out to exactly 16kB diff --git a/slof/fs/accept.fs b/slof/fs/accept.fs index ad361fd..b700f4a 100644 --- a/slof/fs/accept.fs +++ b/slof/fs/accept.fs @@ -1,52 +1,338 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. Nothing fancy for now; just handles CR and BS. +\ Implementation of ACCEPT. Using ECMA-48 for terminal control. -: TABLE-EXECUTE CREATE DOES> swap cells+ @ ?dup IF execute ELSE false THEN ; +: 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 -: handle-backspace accept-len ?dup IF 1- TO accept-len - bs emit space bs emit THEN false ; +: esc 1b emit ; +: csi esc 5b emit ; -: handle-enter space true ; +: 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 ; -TABLE-EXECUTE handle-control +: 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 ; + +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 + /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 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 , -' handle-backspace , 0 , 0 , 0 , -0 , ' handle-enter , 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 + key dup 5b = IF drop key + dup 33 = IF \ DEL + drop key drop ( drops closing 7e ) handle-^D + ELSE + 1f and handle-CSI + THEN + ELSE 1f and handle-meta THEN + ; -: handle-normal - dup emit - accept-len accept-max < IF - accept-adr accept-len chars+ c! - accept-len 1+ TO accept-len - ELSE drop THEN ; +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' ) - TO accept-max TO accept-adr 0 TO accept-len - BEGIN key - dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. - dup bl < IF handle-control IF accept-len exit THEN - ELSE handle-normal THEN - AGAIN ; - -' (accept) TO accept + 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 index 7dc7bd4..89c6a61 100644 --- a/slof/fs/alloc-mem.fs +++ b/slof/fs/alloc-mem.fs @@ -1,19 +1,75 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. -\ For now, just allocate from the data space, and never take space back. +\ 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> -: alloc-mem ( len -- a-addr ) align here swap allot ; -: free-mem ( a-addr len -- ) 2drop ; diff --git a/slof/fs/available.fs b/slof/fs/available.fs new file mode 100644 index 0000000..da80c79 --- /dev/null +++ b/slof/fs/available.fs @@ -0,0 +1,72 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..15527c6 --- /dev/null +++ b/slof/fs/banner.fs @@ -0,0 +1,23 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..9327e53 --- /dev/null +++ b/slof/fs/base.fs @@ -0,0 +1,504 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 missing in *.in files +VARIABLE mask -1 mask ! + +: 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 ; + +: zcount ( zstr -- str len ) dup BEGIN dup c@ WHILE char+ REPEAT over - ; +: zplace ( str len buf -- ) 2dup + 0 swap c! swap move ; + +: 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 +; + +\ 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' ) + ib >in @ + c@ [char] ( = IF + parse-hexstring + ELSE + EXIT + THEN + 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 + +\ Hash for faster lookup +#include <find-hash.fs> + +\ 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> + + +\ 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" :NONE" ; +: 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> diff --git a/slof/fs/boot.fs b/slof/fs/boot.fs new file mode 100644 index 0000000..ded2b0e --- /dev/null +++ b/slof/fs/boot.fs @@ -0,0 +1,247 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + +' (bootdevice) to bootdevice + +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 + ELSE s" diagnostic-mode?" evaluate and IF + s" diag-device" evaluate + ELSE + s" boot-device" evaluate + THEN + THEN + ?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 + 258 set-watchdog \ Set watchdog timer to 10 minutes + 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 + over c@ [char] / = IF + set-boot-device + ELSE + s" " 2swap $cat $cat + THEN + 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 IF + disable-watchdog (go-and-catch) + BEGIN load-next WHILE + (go-and-catch) + REPEAT + + \ When we return from boot print the banner again. + .banner + ELSE + -65 boot-exception-handler + THEN +; + +: 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..91cef6f --- /dev/null +++ b/slof/fs/bootmsg.fs @@ -0,0 +1,74 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 1 + 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 1 + 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 1 + 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..cba0312 --- /dev/null +++ b/slof/fs/claim.fs @@ -0,0 +1,403 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 index 25715ba..01c4686 100644 --- a/slof/fs/client.fs +++ b/slof/fs/client.fs @@ -1,14 +1,14 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. @@ -17,6 +17,11 @@ 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@ ; @@ -25,47 +30,100 @@ VOCABULARY client-voc \ We store all client-interface callable words here. : stack-to-client-data client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ; -: call-client ( p0 p1 client-entry -- ) +: 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 ! + \ 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 drop - \ XXX: 6789 is magic... - CATCH ?dup IF dup 6789 = IF drop r> drop EXIT THEN THROW THEN - stack-to-client-data - ELSE cr client-data l@ zcount type ." NOT FOUND" THEN + 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 6789 THROW ; +: 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-package 0= IF -1 THEN ; + zcount find-node dup 0= IF drop -1 THEN ; : getprop ( phandle zstr buf len -- len' ) - >r >r zcount rot get-property IF ( data dlen R: buf blen ) - r> swap dup r> min swap >r move r> ELSE r> r> 2drop -1 THEN ; + >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 IF nip ELSE -1 THEN ; + zcount rot get-property 0= IF nip ELSE -1 THEN ; : setprop ( phandle zstr buf len -- size|-1 ) dup >r here dup >r swap dup allot move r> r> - dup >r 2swap swap current-package @ >r set-package - zcount property r> set-package r> ; + dup >r 2swap swap current-node @ >r set-node + zcount property r> set-node r> ; +\ 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 ; @@ -73,51 +131,70 @@ ALSO client-voc DEFINITIONS : open ( zstr -- ihandle ) zcount open-dev ; : close ( ihandle -- ) close-dev ; -\ XXX: should return -1 if no such method exists in that node -: write ( ihandle str len -- len' ) rot s" write" rot $call-method ; -: read ( ihandle str len -- len' ) rot s" read" rot $call-method ; -: seek ( ihandle hi lo -- status ) swap rot s" seek" rot $call-method ; - -: claim ( virt size align -- addr ) - \ We don't do any assigned-addresses bookkeeping; furthermore, we're - \ running with translations off, so just tell the client it can have it. - \ XXX: doesn't work if client doesn't ask for a specific address. - 2drop ; -: release ( virt size -- ) - 2drop ; +\ 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 ; -: instance-to-path ( ihandle buf len -- len' ) - \ XXX: we do no buffer overflow checking! - drop >r ihandle>phandle s" full_name" rot get-property drop - r> swap dup >r move r> 1- ; - : package-to-path ( phandle buf len -- len' ) - \ XXX: we do no overflow checking! - drop >r s" full_name" rot get-property IF r> swap dup >r move r> 1- - ELSE true ABORT" No full_name property?!?" THEN ; + 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 - dup IF nrets 1 ?DO -444 LOOP THEN - nrets flip-stack ; + 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 ; -: interpret ( ... zstr -- result ... ) - \ XXX: we just throw away the arguments. - nargs 0 ?DO drop LOOP nrets 1 ?DO -555 LOOP -667 ; +\ From the PAPR. +: test-method ( phandle str -- missing? ) + zcount rot find-method dup IF nip THEN 0= ; -\ XXX: no real clock, but monotonically increasing, at least ;-) -VARIABLE milliseconds -: milliseconds milliseconds @ 1 milliseconds +! ; +: milliseconds milliseconds ; : start-cpu ( phandle addr r3 -- ) - \ phandle isn't actually used, but that's no problem on a 2-CPU system. - 3fc0 l! 3f80 l! 3f40 l! ; + >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 ; -\ Just to shut up warnings resulting from Linux calling this whether it -\ exists or not. It isn't even standard, but hey. -: quiesce ; +\ 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..b2593dc --- /dev/null +++ b/slof/fs/debug.fs @@ -0,0 +1,346 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +; + +: (see-colon) ( xt -- ) + ." : " dup (.xt) cr 3 spaces + BEGIN + cell + dup @ + dup <semicolon> <> + WHILE + dup (.xt) ." " + CASE + <0branch> OF cell+ dup @ . ENDOF + <branch> OF cell+ dup @ . ENDOF + <do?do> OF cell+ dup @ . ENDOF + <lit> OF cell+ dup @ . ENDOF + <dotick> OF cell+ dup @ (.xt) ." " ENDOF + <doloop> OF cell+ dup @ . ENDOF + <do+loop> OF cell+ dup @ . ENDOF + <sliteral> OF cell+ dup count dup >r type ." " + r> -cell and + .s ENDOF + dup OF ." " ENDOF + ENDCASE + REPEAT + 2drop + cr ." ;" +; + +\ 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 +: 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 +; + +: trace-print ( -- ) + forth-ip cr u. ." : " + forth-ip @ 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 +; + +\ Save execution token address and content + +0 value debug-last-xt +0 value debug-last-xt-content + +\ Main trace routine, trace a colon definition + +: trace-xt ( xt -- ) + debug-last-xt ['] breakpoint @ swap ! \ Re-arm break point + r> drop \ Drop return of 'trace-xt call + cell + to forth-ip \ Step over ":" + 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+ 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 @ 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 + <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- 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-content debug-last-xt ! \ Restore overwriten token + r> drop \ Don't return to bp, but to caller + debug-last-xt-content <colon> <> 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 trace-xt \ Trace colon definition + THEN +; + +\ Put entry point bp defer +' (break-entry) to BP + +\ 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..7cf3493 --- /dev/null +++ b/slof/fs/devices/pci-class_02.fs @@ -0,0 +1,35 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..8c3d43c --- /dev/null +++ b/slof/fs/devices/pci-class_0c.fs @@ -0,0 +1,39 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..ab9f2a5 --- /dev/null +++ b/slof/fs/devices/pci-device_10de_0141.fs @@ -0,0 +1,49 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..15cc2cb --- /dev/null +++ b/slof/fs/dictionary.fs @@ -0,0 +1,74 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..f0ffae0 --- /dev/null +++ b/slof/fs/display.fs @@ -0,0 +1,124 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 index 1b9e883..a7c17fd 100644 --- a/slof/fs/dump.fs +++ b/slof/fs/dump.fs @@ -1,26 +1,42 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 +\ ****************************************************************************/ -\ Hexdump thingy. A bit simplistic, always prints full lines. +\ Hex dump facilities. -hex - -DEFER dump-c@ -: .2 ( u -- ) 0 <# # # #> type space ; -: .char ( c -- ) dup bl 7e between 0= IF drop [char] . THEN emit ; -: dumpline ( addr -- ) - cr dup 8 u.r ." : " dup 10 bounds DO i dump-c@ .2 LOOP - space space 10 bounds DO i dump-c@ .char LOOP ; -: (dump) ( addr size -- ) bounds DO i dumpline 10 +LOOP ; -: dump ['] c@ to dump-c@ (dump) ; -: rdump ['] rb@ to dump-c@ (dump) ; +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 index 997774d..f7edf76 100644 --- a/slof/fs/elf.fs +++ b/slof/fs/elf.fs @@ -1,19 +1,14 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 loader. - -\ Author: Hartmut Penner <hpenner@de.ibm.com> +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 @@ -22,7 +17,7 @@ STRUCT /c field ehdr>e_class /c field ehdr>e_data /c field ehdr>e_version - /c field ehdr>e_pad + /c field ehdr>e_pad /l field ehdr>e_ident_2 /l field ehdr>e_ident_3 /w field ehdr>e_type @@ -61,7 +56,7 @@ STRUCT /c field ehdr64>e_class /c field ehdr64>e_data /c field ehdr64>e_version - /c field ehdr64>e_pad + /c field ehdr64>e_pad /l field ehdr64>e_ident_2 /l field ehdr64>e_ident_3 /w field ehdr64>e_type @@ -84,7 +79,7 @@ END-STRUCT STRUCT /l field phdr64>p_type - /l field phdr64>p_flags + /l field phdr64>p_flags cell field phdr64>p_offset cell field phdr64>p_vaddr cell field phdr64>p_paddr @@ -93,117 +88,183 @@ STRUCT cell field phdr64>p_align END-STRUCT -: load-segment ( file-addr program-header-addr -- ) - ( file-addr program-header-addr ) - dup >r phdr>p_vaddr l@ r@ phdr>p_memsz l@ erase +\ Claim memory for segment +\ Abort, if no memory available - ( file-addr R: programm-header-addr ) - r@ phdr>p_vaddr l@ r@ phdr>p_memsz l@ dup 0= IF 2drop ELSE flushcache THEN +false value elf-claim? +0 value last-claim - ( file-addr R: programm-header-addr ) - r@ phdr>p_offset l@ + r@ phdr>p_vaddr l@ r> phdr>p_filesz l@ move +: 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 ; +: load-segment ( file-addr program-header-addr -- ) + >r + ( file-addr R: program-header-addr ) + \ Copy into storage + r@ phdr>p_offset l@ + r@ phdr>p_vaddr l@ r@ phdr>p_filesz l@ move + + ( R: programm-header-addr ) + \ Clear BSS + r@ phdr>p_vaddr l@ r@ phdr>p_filesz l@ + + r@ phdr>p_memsz l@ r@ phdr>p_filesz l@ - erase + + ( R: programm-header-addr ) + \ Flush cache + r@ phdr>p_vaddr l@ r> phdr>p_memsz l@ dup 0= IF 2drop ELSE flushcache THEN +; : load-segments ( file-addr -- ) - ( 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 ) + ( 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 + 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 + nip nip \ cleanup ; -: load-segment64 ( file-addr program-header-addr -- ) +: 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 - ( file-addr program-header-addr ) - dup >r phdr64>p_vaddr @ r@ phdr64>p_memsz @ erase + ( R: programm-header-addr ) + \ Clear BSS + r@ phdr64>p_vaddr @ r@ phdr64>p_filesz @ + + r@ phdr64>p_memsz @ r@ phdr64>p_filesz @ - erase - ( file-addr R: programm-header-addr ) - r@ phdr64>p_vaddr @ r@ phdr64>p_memsz @ dup 0= IF 2drop ELSE flushcache THEN - - ( file-addr R: programm-header-addr ) - r@ phdr64>p_offset @ + r@ phdr64>p_vaddr @ r> phdr64>p_filesz @ move + ( 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 ) + ( 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 ) + ( file-addr program-header-addr ) dup phdr64>p_type l@ 1 = IF \ PT_LOAD ? - + + ( file-addr program-header-addr ) + 2dup claim-segment \ 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 + 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 + nip nip \ cleanup ; : elf-check-file ( file-addr -- 1 : 32, 2 : 64, else bad ) ( file-addr ) - dup ehdr>e_ident l@ 7f454c46 <> ABORT" Not an ELF file" - + dup ehdr>e_ident l@-be 7f454c46 <> IF + ABORT" Not an ELF executable" + THEN + ( file-addr ) - dup ehdr>e_data c@ 2 <> ABORT" Not a Big Endian ELF file" + 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" + dup ehdr>e_type w@ 2 <> ABORT" Not an ELF executable" ( file-addr ) dup ehdr>e_machine w@ dup 14 <> swap 15 <> and ABORT" Not a PPC ELF executable" ( file-addr) ehdr>e_class c@ -; +; -: load-elf32 ( file-addr -- ) +: load-elf32 ( file-addr -- entry ) - ( file-addr) + ( file-addr) load-segments ; -: load-elf64 ( file-addr -- ) +: 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) + ( file-addr) load-segments64 ; -: load-elf-file ( file-addr -- entry ) +: 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 ) + dup elf-check-file ( file-addr 1|2|x ) CASE - 1 OF load-elf32 ENDOF - 2 OF load-elf64 ENDOF + 1 OF load-elf32 true ENDOF + 2 OF load-elf64 false ENDOF dup OF true ABORT" Neither 32- nor 64-bit ELF file" ENDOF ENDCASE ; + +\ 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 index 0cdb9f6..de96e43 100644 --- a/slof/fs/envvar.fs +++ b/slof/fs/envvar.fs @@ -1,93 +1,400 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. Not actually used yet, nor shown in /options. +\ configuration variables wordlist CONSTANT envvars -: listenv get-current envvars set-current words set-current ; +\ list the names in envvars +: listenv get-current envvars set-current words set-current ; +\ create a definition in envvars : create-env ( "name" -- ) - get-current >r envvars set-current CREATE r> set-current ; + 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 ( a len -- ) 3 c, string, DOES> char+ count ; + 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 ; -: findenv ( name len -- adr def-adr type ) - 2dup envvars voc-find dup 0= ABORT" not a configuration variable" - link> >body char+ >r (find-order) link> >body dup char+ swap c@ r> swap ; +: 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 -- ) - 2dup findenv nip nip -rot $CREATE CASE - 1 OF evaluate env-int ENDOF \ XXX: wants decimal and 0x... - 2 OF env-bytes ENDOF - 3 OF env-string ENDOF - 4 OF evaluate env-flag ENDOF - 5 OF evaluate env-secmode ENDOF \ XXX: recognize none, command, full - ENDOF ENDCASE ; -: setenv parse-word skipws 0 parse 2swap $setenv ; + 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 +; + +\ : setenv parse-word skipws 0 parse 2swap $setenv ; +: setenv parse-word ( skipws ) 0d parse -leading 2swap $setenv ; +\ print an envvar : (printenv) ( adr type -- ) - CASE - 1 OF aligned @ . ENDOF - 2 OF aligned dup cell+ swap @ dump ENDOF - 3 OF count type ENDOF - 4 OF c@ IF ." true" ELSE ." false" THEN ENDOF - 5 OF c@ . ENDOF \ XXX: print symbolically - ENDCASE ; -: printenv parse-word findenv rot over cr ." Current: " (printenv) - cr ." Default: " (printenv) ; + 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 ; + 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 ; : set-default parse-word envvars voc-find - dup 0= ABORT" not a configuration variable" link> (set-default) ; + dup 0= ABORT" not a configuration variable" link> (set-default) ; : set-defaults envvars cell+ BEGIN @ dup WHILE dup link> (set-default) REPEAT drop ; +\ 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" 1 2 3 * + ." default-string nvramrc +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 -50 default-int screen-#columns -18 default-int screen-#rows +200 default-int screen-#columns +200 default-int screen-#rows 0 default-int security-#badlogins -0 default-secmode security-mode +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? + set-defaults + +VARIABLE nvoff \ 70 get-header 2drop nvoff ! + +: (nvupdate-one) ( adr type -- ) + CASE + 1 OF aligned @ . ENDOF + 2 OF drop ." 0 0" ENDOF + 3 OF count type ENDOF + 4 OF c@ IF ." true" ELSE ." false" THEN ENDOF + 5 OF c@ . ENDOF \ XXX: print symbolically + ENDCASE ; +: nvupdate-one ( def-xt -- ) + >name name>string + ( ." setenv " 2dup type space ) \ Old Implementation + 2dup type s" =" type + findenv nip (nvupdate-one) + ( cr ) \ Old Implementation + 0 emit + ; + +: (nvupdate) envvars cell+ BEGIN @ dup WHILE dup link> nvupdate-one REPEAT + drop ; + +: nvemit nvoff @ rb! 1 nvoff +! 0 nvoff @ rb! ; +: nvupdate + 70 get-header 2drop nvoff ! + ['] emit behavior ['] nvemit to emit (nvupdate) to emit ; + + + +: get-nv ( -- ) + 70 get-header ( addr offset not-found | not-found ) \ find partition header + IF + create-default-headers \ partition header not found: set default values + nvupdate + 70 get-header 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 $nvalias +; + +: $nvunalias ( name-str name-len -- ) + s" " ['] (nv-build-null-entry) (nv-build-nvramrc) + nvupdate +; + +: nvunalias ( "alias-name< >" -- ) + parse-word $nvunalias +; + +: diagnostic-mode? diag-switch? ; + diff --git a/slof/fs/exception.fs b/slof/fs/exception.fs new file mode 100644 index 0000000..d243eb9 --- /dev/null +++ b/slof/fs/exception.fs @@ -0,0 +1,154 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..3167ca5 --- /dev/null +++ b/slof/fs/fbuffer.fs @@ -0,0 +1,178 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..39ee3ed --- /dev/null +++ b/slof/fs/fcode/1275.fs @@ -0,0 +1,353 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..c2cb8d9 --- /dev/null +++ b/slof/fs/fcode/big.fs @@ -0,0 +1,45 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..8cfadeb --- /dev/null +++ b/slof/fs/fcode/core.fs @@ -0,0 +1,169 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..a0249ab --- /dev/null +++ b/slof/fs/fcode/evaluator.fs @@ -0,0 +1,99 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..bf76b8b --- /dev/null +++ b/slof/fs/fcode/tokens.fs @@ -0,0 +1,411 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 index 31ee66f..2d6facf 100644 --- a/slof/fs/find-hash.fs +++ b/slof/fs/find-hash.fs @@ -1,30 +1,33 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 +\ ****************************************************************************/ -\ A simple little hash table, to speed up compiling. Quite important if -\ running on a CPU emulator; on real hardware, not so. - -CREATE name-hash 20 cells allot -: clean-hash name-hash 20 cells erase ; +CREATE name-hash 200 cells allot +: clean-hash name-hash 200 cells erase ; clean-hash -: hash ( str len -- hash ) swap c@ xor 1f and cells name-hash + ; +\ The hash algorithm (AND with 1f is necessary because of case insensitivity) +: hash ( str len -- hash ) + f and 5 lshift swap c@ 1f and xor cells name-hash + +; + : hash-find ( str len head -- 0 | link ) >r 2dup 2dup hash dup >r @ dup IF link>name name>string string=ci ELSE nip nip THEN IF 2drop r> @ r> drop exit THEN r> r> swap >r ((find)) dup IF dup r> ! ELSE r> drop THEN ; + : hash-reveal hash off ; + ' hash-reveal to (reveal) ' hash-find to (find) diff --git a/slof/fs/generic-disk.fs b/slof/fs/generic-disk.fs new file mode 100644 index 0000000..bfbcb15 --- /dev/null +++ b/slof/fs/generic-disk.fs @@ -0,0 +1,68 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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/ide.fs b/slof/fs/ide.fs index addb885..59c8438 100644 --- a/slof/fs/ide.fs +++ b/slof/fs/ide.fs @@ -1,78 +1,625 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 ; -\ ATA disk. +0 VALUE >ata \ base address for command-block +0 VALUE >ata1 \ base address for control block -\ We run it at PIO mode 0; this is a) not too slow for the sizes we have to -\ handle, and b) works with all disks. -\ We assume there is a disk drive connected; however, if not, nothing will -\ crash. +true VALUE no-timeout \ flag that no timeout occured -new-device s" /ht/ata@4,1/disk" full-name +0c CONSTANT #cdb-bytes \ command descriptor block (12 bytes) -s" disk" device-name s" block" device-type +\ ***************************** +\ 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 -: open true ; -: close ; +\ ********************************************************************** +\ 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 -\ Some register access helpers. -: ata-ctrl! 3f6 io-c! ; \ device control reg -: ata-data@ 1f0 io-w@ ; \ data reg -: ata-cnt! 1f2 io-c! ; \ sector count reg -: ata-lbal! 1f3 io-c! ; \ lba low reg -: ata-lbam! 1f4 io-c! ; \ lba mid reg -: ata-lbah! 1f5 io-c! ; \ lba high reg -: ata-dev! 1f6 io-c! ; \ device reg -: ata-cmd! 1f7 io-c! ; \ command reg -: ata-stat@ 1f7 io-c@ ; \ status reg - -\ Init controller; we use the master device only. -02 ata-ctrl! -00 ata-dev! - -CREATE sector 200 allot - -: wait-for-ready BEGIN ata-stat@ 80 and WHILE REPEAT ; -: pio-sector ( addr -- ) 100 0 DO ata-data@ over w! wa1+ LOOP drop ; -: pio-sector ( addr -- ) wait-for-ready pio-sector ; +\ ***************************** +\ Setup Regs for ATA: +\ BAR 0 & 1 : Device 0 +\ BAR 2 & 3 : Device 1 +\ ***************************** +: set-regs ( n -- ) +\ dup ." < Set #" . \ *** DEBUG LINE **** + 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 and + IF + 10 + ELSE + 00 + THEN + ata-dev! +\ >ata ." /" . ata-astat@ ." /" . ." > " \ *** DEBUG LINE *** +; + + 200 VALUE block-size +80000 VALUE max-transfer \ Arbitrary, really + +CREATE sector d# 512 allot +CREATE packet-cb #cdb-bytes allot +CREATE packet-buffer 800 allot + +\ ******************************** +\ 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 + ." (Err : " . ." )" \ show err-reg content + 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# 1000 / \ bytes -> kbytes (avoid 32-bit overflow) + d# 512 * \ LBA = 512 Bytes + d# 500 + \ round +- 0.5 + d# 1000 / \ kB -> MB + dup + d# 1000 > + IF + d# 500 + + d# 1000 / + ." (" .d ." GB)" + ELSE + ." (" .d ." MB)" + THEN + 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 ; -: read-ident ec ata-cmd! 1 sector pio-sectors ; -read-ident sector d# 54 + d# 40 wbflips -cr .( Disk drive identifies as: ) sector d# 54 + d# 40 type +: 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) +; -: lba! lbsplit f and 40 or ata-dev! ata-lbah! ata-lbam! ata-lbal! ; -: read-sectors ( lba count addr -- ) +: read-sectors ( lba count addr -- ) >r dup >r ata-cnt! lba! 20 ata-cmd! r> r> pio-sectors ; -: read-sectors ( lba count addr -- ) - BEGIN >r dup 100 > WHILE - over 100 R@ read-sectors - >r 100 + r> 100 - r> 20000 + REPEAT - r> read-sectors ; -' read-sectors to disk-read -200 CONSTANT block-size -0 VALUE disk-offset -CREATE deblock 20000 allot +: 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 req-len -- ) + >r ( req-len R: req-buffer ) + 800 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-cb 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 target buffer address + read-pio-block \ only if from device requested + >r \ start of next block + REPEAT + r> + drop +; + +\ ******************************** +\ ATAPI packet commands +\ ******************************** +03 CONSTANT scsi-cmd#request-sense +12 CONSTANT scsi-cmd#inquiry +28 CONSTANT scsi-cmd#read10 +A8 CONSTANT scsi-cmd#read12 +25 CONSTANT scsi-cmd#read-capacity +2B CONSTANT scsi-cmd#seek + +\ Methods to access atapi disk + +: atapi-test ( -- true|false ) + packet-cb #cdb-bytes erase \ command-code 0 + packet-buffer send-atapi-packet + ata-stat@ 1 and IF false ELSE true THEN +; + +: atapi-sense ( -- ASC sense-key ) + packet-cb #cdb-bytes erase + scsi-cmd#request-sense packet-cb c! \ set command-code 03h + 12 packet-cb 4 + c! \ allocation length = 18 + packet-buffer send-atapi-packet + packet-buffer d# 12 + c@ \ additional sense code (ASC) + packet-buffer 2 + c@ f and \ sense key +; + +: atapi-inquiry ( -- ) + packet-cb #cdb-bytes erase \ set command-code 12h + scsi-cmd#inquiry packet-cb c! + 24 packet-cb 4 + c! + packet-buffer send-atapi-packet +; + +: atapi-capacity ( -- ) + packet-cb #cdb-bytes erase + scsi-cmd#read-capacity packet-cb c! \ set command-code 25h + packet-buffer send-atapi-packet +; + +: atapi-seek ( offset -- ) + packet-cb #cdb-bytes erase + scsi-cmd#seek packet-cb c! \ set command code 2bh + packet-cb 4 + l! + packet-buffer send-atapi-packet +; + +: atapi-start ( cmd -- ) + packet-cb #cdb-bytes erase + 1b packet-cb c! + packet-cb 4 + c! + packet-buffer send-atapi-packet +; + +: atapi-toc ( -- ) + packet-cb #cdb-bytes erase + 43 packet-cb c! + 200 packet-cb 7 + w! + packet-buffer send-atapi-packet +; + +: atapi-read ( offset cnt -- ) + packet-cb #cdb-bytes erase + scsi-cmd#read10 packet-cb c! \ set command code 28h + packet-cb 7 + w! \ 2 bytes: Transfer Length + packet-cb 2 + l! \ 4 bytes: Block-Address + packet-buffer send-atapi-packet +; + +: atapi-read-blocks ( address block# #blocks dev# -- #read-blocks ) + set-regs ( dev# -- ) + dup >r + packet-cb #cdb-bytes erase + scsi-cmd#read10 packet-cb c! \ set command code 28h + packet-cb 7 + w! \ 2 bytes: Transfer Length + packet-cb 2 + l! \ 4 bytes: Block-Address + send-atapi-packet + r> +; + +\ *********************************************** +\ 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 ( -- asc sensekey ) + 02 = \ sense key 2 = media error + IF \ check add. sense code + 3A = IF false to no-timeout ." empty" THEN \ medium not present, abort waiting + ELSE + drop \ discard add. sense code + 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/slacve) 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 +; -: seek ( lo hi -- status ) 20 lshift or to disk-offset 1 ; +\ ************************************************* +\ 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 +\ ************************************************* -: read ( str len -- len' ) \ max 20000 bytes - disk-offset 200 / over disk-offset + 1ff + 200 / over - deblock disk-read - >r deblock disk-offset 1ff and + swap r@ move r> - disk-offset over + to disk-offset ; +: 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 + 02 ata-ctrl! \ disable interrupts + 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 + 800 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 + 200 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 + LOOP + LOOP +; -: read ( str len -- len' ) - dup >r BEGIN dup WHILE 2dup 20000 min read tuck - >r + r> REPEAT 2drop r> ; +find-disks -finish-device diff --git a/slof/fs/instance.fs b/slof/fs/instance.fs index f5b480b..22be971 100644 --- a/slof/fs/instance.fs +++ b/slof/fs/instance.fs @@ -1,36 +1,36 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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-init is a linked list, before finish-package. -\ entry format: offset in instance, link, initial value. -\ after finish-package it's a pointer to a memory block -\ that is copied verbatim for every instance. -\ This will have to be revisited, as it is not quite right: -\ an instance variable can be used before the package is -\ completed. +: >instance + my-self 0= ABORT" No instance!" + my-self + +; -: (create-instance-var) ( "name" initial-value link-addr size-addr -- ) - CREATE dup @ , 1 cells swap +! linked , ; +: (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 -- ) - current-package @ dup pkg>instance-init swap pkg>instance-size - (create-instance-var) PREVIOUS DEFINITIONS ; - -: >instance my-self + ; + CREATE (create-instance-var) PREVIOUS ; VOCABULARY instance-words ALSO instance-words DEFINITIONS @@ -41,54 +41,90 @@ VOCABULARY instance-words ALSO instance-words DEFINITIONS PREVIOUS DEFINITIONS -: INSTANCE current-package @ 0= ABORT" No current package" - ALSO instance-words ; - -VARIABLE shared-instance-link -VARIABLE shared-instance-size - -: SIVARIABLE 0 shared-instance-link shared-instance-size (create-instance-var) - DOES> @ >instance ; - -VOCABULARY shared-instance-vars ALSO shared-instance-vars DEFINITIONS - -SIVARIABLE the-package \ needs to be first! -SIVARIABLE the-parent -SIVARIABLE the-addr -SIVARIABLE the-addr1 -SIVARIABLE the-addr2 -SIVARIABLE the-args -SIVARIABLE the-args-len - -PREVIOUS DEFINITIONS -: shared-instance-words ['] shared-instance-vars >body cell+ @ ; - - -ALSO shared-instance-vars - -: my-parent the-parent @ ; -: my-args the-args 2@ ; -: set-my-args dup alloc-mem swap 2dup the-args 2! move ; - -\ Current package has already been set, when this is called. +\ 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 ) - current-package @ dup pkg>instance-init @ swap pkg>instance-size @ - dup alloc-mem dup >r swap move r> ; -: create-instance my-self create-instance-data to my-self the-parent ! - current-package @ the-package ! ; -: destroy-instance ( instance -- ) - dup @ pkg>instance-size @ free-mem ; - -PREVIOUS + 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 ( 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-my-method ( str len -- ) my-self ihandle>phandle find-method - 0= ABORT" no such method" execute ; +: $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..76ce370 --- /dev/null +++ b/slof/fs/little-endian.fs @@ -0,0 +1,72 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..b799692 --- /dev/null +++ b/slof/fs/loaders.fs @@ -0,0 +1,71 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +\ ****************************************************************************/ + + +: 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 +; diff --git a/slof/fs/logging.fs b/slof/fs/logging.fs new file mode 100644 index 0000000..293a013 --- /dev/null +++ b/slof/fs/logging.fs @@ -0,0 +1,41 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 -- ) + 0 DO dup c@ + nvramlog-write-byte char+ LOOP 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..4ae52b0 --- /dev/null +++ b/slof/fs/node.fs @@ -0,0 +1,663 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 get-node #address-cells ; \ bit of a misnomer... "my-" + +: encode-phys ( phys.hi ... phys.low -- str len ) + encode-first? IF encode-start ELSE here 0 THEN + my-#address-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 ; + + +\ Pseudocode in C Syntax +\ if((addr>=child)&&(addr<=child+size) +\ return (addr - child) + parent +\ else return false +\ +: translate-range ( child parent size addr -- taddr true | addr false ) + swap 3 pick + over \ calculate child+size address + ( child parent size addr child+size ) + > IF \ verify if addr is below child+size address + ( child parent addr ) + 2 pick over \ fetch child and addr for compare + ( child parend addr child addr ) + <= IF \ verify if addr is above child address + ( child parent addr ) + 2 pick - + nip true \ pick child, calculate addr-child + parent, drop child and return true + ( taddr true ) + ELSE + 2drop false \ drop child parent size and return false + ( addr false ) + THEN + ELSE + ( child parent addr ) + nip nip false \ drop child parent size and return false + ( addr false ) + THEN +; + +\ helper function based on decode-int to decode an integer property +\ from a prop-encoded-array +\ my-property cannot be used since this depends on a current instance +: get-property-decoded ( addr len -- n ) + get-node get-property + IF cr cr cr ." get-property-decoded: no such property" EXIT THEN decode-int nip nip +; + +0 VALUE pci-phys-hi +1C000000 CONSTANT pci-stop-mapping-code +\ Explanation to pci-stop-mapping-code: +\ Bits 26..28 are unsused in phys.hi in the IEEE 1275 PCI binding +\ and set to 0. Use value where these bits are set in pci-phys-hi to communicate that +\ translation sould stop. + +\ Helper function to extract one element of the child parent size tuple coded +\ into the ranges properties array, element being exactly one of child, parent +\ and size +: extract-range-element ( ranges-addr ranges-len #cells -- element ranges-addr' ranges-len' ) + \ -rot decode-int 3 roll 1 > IF 20 lshift -rot decode-int 3 roll + THEN -rot + CASE + 1 OF decode-int -rot ENDOF + 2 OF decode-int 20 lshift -rot decode-int 3 roll + -rot ENDOF + 3 OF + BEGIN + dup 0= IF + false ( ranges-addr ranges-len false ) + ELSE + decode-int + pci-phys-hi \ for PCI phys.hi lies on the stack below addr + space-code-mask and + <> \ compare phys.hi + THEN + WHILE + \ discard phys.mid, phys.lo, parent, and size values. Then go to next PCI ranges tuple + 18 dup -rot - -rot + swap + REPEAT + + dup 0= IF ( ranges-addr ranges-len ) + pci-stop-mapping-code to pci-phys-hi ( ranges-addr ranges-len ) + ELSE + \ ranges size >= 8, since phys.hi + \ was read in ELSE of WHILE condition + decode-int 20 lshift -rot decode-int 3 roll + -rot + THEN + ENDOF + ENDCASE +; + +\ Function to convert a whole child parent size sequence into decoded-int format +: extract-range ( ranges-addr ranges-len -- child parent size ranges-addr' ranges-len' ) + \ child + s" #address-cells" get-property-decoded + extract-range-element + \ exit criterium for PCI: ranges-len is 0 and false on top of stack + pci-phys-hi pci-stop-mapping-code = IF EXIT THEN ( ranges-addr ranges-len ) + + \ parent ( child ranges-addr' ranges-len' ) + decode-phys ( child ranges-addr" ranges-len" phys.lo .. phys.hi ) + my-#address-cells 1 > IF 20 lshift + THEN ( child ranges-addr''' ranges-len''' parent ) + -rot ( child parent ranges-addr''' ranges-len''' ) + + \ size + s" #size-cells" get-property-decoded ( child parent ranges-addr''' ranges-len''' #size-cells ) + extract-range-element ( child parent size ranges-addr"" ranges-len"" ) +; + +\ Function to process a whole array one or more of child parent size sequences +\ Prerequisite: Empty ranges handing is assumed to already exist. +: translate-ranges-node ( addr ranges-addr ranges-len -- taddr true|false ) + BEGIN + dup 0 > \ ranges-len > 0 + WHILE + extract-range + pci-phys-hi pci-stop-mapping-code = + IF ( addr ranges-addr ranges-len ) + nip nip EXIT ( false ) + THEN + ( addr child parent size ranges-addr' ranges-len' ) + 2rot ( parent size ranges-addr' ranges-len' addr child ) + 5 roll ( size ranges-addr' ranges-len' addr child parent ) + 5 roll ( ranges-addr' ranges-len' addr child parent size ) + 3 roll ( ranges-addr' ranges-len' child parent size addr ) + translate-range ( ranges-addr' ranges-len' taddr true | ranges-addr' ranges-len' addr false ) + IF nip nip true EXIT + ELSE ( ranges-addr' ranges-len' addr ) + -rot + ( addr ranges-addr' ranges-len' ) + THEN + REPEAT + ( ranges-addr' ranges-len' taddr true | ranges-addr' ranges-len' false ) + \ remove addr ranges-addr' ranges-len' from stack + nip nip \ leaving the 0 ranges-len' as false + ( false ) +; + +\ Helper function to search the first ranges in current node or one of its parents +\ and make that node the 'current node' +\ Prerequisite: root node must have a ranges property +\ Returns address, length, true if ranges property was found, otherwise false. +: translate-set-to-next-ranges-node ( -- addr-ranges len-ranges true|false ) + s" ranges" 2dup get-node get-property + IF + ( addr len true ) + get-parent dup set-node get-property + IF + cr cr cr + s" no translatable address space due to missing ranges property" type + cr cr cr + false + ELSE + true + THEN + ELSE + ( addr len addr-ranges len-ranges ) + rot drop rot drop true + THEN + ( ranges-addr ranges-len true|false ) +; + +: translate-address-end ( phandle-start taddr true|phandle-start false ) + \ get back to the node where translation was started + dup IF + rot ( taddr true phandle-start ) + set-node ( taddr true ) + ELSE + swap ( phandle-start false ) + set-node ( false ) + THEN +; + +\ Function to step up the device tree up to the root node. +\ Contains empty ranges handling. +\ Returns the translated address and true, when the address is translatable, otherwise false. +: translate-ranges ( addr -- taddr true|false ) + BEGIN + \ set-node semantic required here to continue from nodes found below. + translate-set-to-next-ranges-node + not IF false EXIT THEN ( false ) \ address is not translatable + \ due to missing ranges property in the hierarchy. + ( phandle-start addr ranges-addr ranges-len ) + dup 0= + IF + \ empty ranges property detected, assume 1 : 1 translation + 2drop true + ( phandle-start addr true ) + ELSE + ( phandle-start addr ranges-addr ranges-len ) + translate-ranges-node + ( phandle-start taddr true|phandle-start false ) + THEN + dup IF + ( phandle-start taddr true ) \ found a translation + drop + get-parent + dup 0= + IF \ arrived at root node, stop translation + drop true dup + ( phandle-start taddr true true ) + ELSE + \ go to parent and continue + set-node false + ( phandle-start taddr true phandle-parent false ) + THEN + ELSE + true \ address translation failed, exit loop + ( phandle-start false true ) + THEN + UNTIL + ( phandle-start taddr true|phandle-start false ) +; + + +: translate-address-back-to-start-node ( phandle-start taddr true|phandle-start false ) + \ get back to the node where translation was started + dup IF + rot ( taddr true phandle-start ) + set-node ( taddr true ) + ELSE + swap ( phandle-start false ) + set-node ( false ) + THEN +; + +: translate-address ( addr -- taddr true|false ) + get-node swap \ save current node ( phandle-start addr ) + translate-ranges ( phandle-start taddr true|phandle-start false ) + translate-address-back-to-start-node ( taddr true|false ) +; + + +: translate-address-pci ( phys.lo phys.mid phys.hi -- taddr true|false ) + to pci-phys-hi ( phys.lo phys.mid ) + lxjoin ( phys.addr ) + get-node \ save current node ( phys.addr phandle-start ) + swap ( phandle-start phys.addr ) + translate-ranges \ fetches phys.hi for PCI ( phandle-start taddr true|phandle-start false ) + translate-address-back-to-start-node ( taddr true|false ) +; + +\ 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..5d8344b --- /dev/null +++ b/slof/fs/nvram.fs @@ -0,0 +1,259 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +\ ****************************************************************************/ + +: rztype ( str len -- ) \ stop at zero byte, read with rb@ + BEGIN dup WHILE swap dup rb@ dup WHILE + emit char+ swap 1- REPEAT drop THEN 2drop ; + +: rtype ( str len -- ) + 0 DO dup rb@ emit char+ LOOP drop ; + +: mrzplace ( str len buf -- ) 2dup + 0 swap rb! swap mrmove ; + +create tmpStr 500 allot +: rzcount ( zstr -- str len ) + dup tmpStr >r BEGIN dup rb@ dup r> dup 1+ >r c! WHILE char+ REPEAT + r> drop over - swap drop tmpStr swap ; + +: >nvram nvram-base + ; + +: calc-header-cksum ( offset -- cksum ) + >nvram dup rb@ + 10 2 DO + over i + rb@ + + LOOP + wbsplit + nip +; + +: bad-header? ( offset -- flag ) + dup >nvram 2+ rw@ ( offset length ) + 0= IF ( offset ) + drop true EXIT ( ) + THEN + dup calc-header-cksum ( offset checksum' ) + swap >nvram 1+ rb@ ( checksum ' checksum ) + <> ( flag ) +; + +: .header ( offset -- ) + cr ( offset ) + dup bad-header? IF ( offset ) + ." BAD HEADER -- trying to print it anyway" cr + THEN + space >nvram ( adr ) + \ print type + dup rb@ 2 0.r ( adr ) + space space ( adr ) + \ print length + dup 2+ rw@ 10 * 5 .r ( adr ) + space space ( adr ) + \ print name + 4 + 0c rztype ( ) +; + +: .headers ( -- ) + cr cr ." Type Size Name" + cr ." ========================" + 0 BEGIN ( offset ) + dup >nvram ( offset adr ) + rb@ ( offset type ) + WHILE + dup .header ( offset ) + dup >nvram 2+ rw@ 10 * + ( offset offset' ) + dup nvram-size < IF ( offset ) + ELSE + drop EXIT ( ) + THEN + REPEAT + drop ( ) + cr cr +; + +: find-header ( type -- offset false | true ) + 0 >r ( type R: offset ) + BEGIN + r@ >nvram ( type adr ) ( R: offset ) + rb@ 2dup ( type sig type sig ) ( R: offset ) + = IF ( type sig ) ( R: offset ) + 2drop r> false EXIT ( offset false ) + THEN + WHILE + r> dup ( type offset offset ) + bad-header? IF ( type offset ) + 2drop true EXIT ( true ) + THEN + dup >nvram 2+ rw@ 10 * ( tyoe offset length ) + + >r ( type ) ( R: offset' ) + REPEAT + r> 2drop true ( true ) +; + +: get-header ( type -- data len false | true ) + find-header ?dup IF ( offset false | true ) + EXIT ( true ) + THEN + dup ( offset offset ) + bad-header? ?dup IF ( offset true | offset ) + nip EXIT ( true ) + THEN + >nvram ( adr ) + dup 10 + swap ( adr' adr ) + 2+ rw@ 1- 10 * ( adr length ) + false ( adr length true ) +; + +\ FIXME: This function should return if it succeeded! +: add-header ( type size name len -- ) + rot dup >r 10 / ( type name len size/10 R:size ) + 7f get-header IF ( type name len size/10 R:size ) + r> drop 4drop + ." couldn't find free partition" \ FIXME this should be a warning!!! + EXIT + THEN + r> 2dup <= IF + 2drop 2drop 3drop + ." couldn't find space in free partition" + EXIT + THEN + - 10 + 10 / >r dup e - r> swap rw! \ write new free size + 10 - dup dup nvram-base - calc-header-cksum swap 1+ rb! + dup 2+ rw@ 10 * + \ now we are on next header offset + dup >r 2+ rw! \ write new size + rot r@ rb! \ write type + r@ 4 + mrzplace \ write name + r@ nvram-base - calc-header-cksum r> 1+ rb! +; + +: create-header ( type size name len -- ) + 0 find-header ABORT" couldn't find space for new NVRAM partition" + \ write name + dup >r >nvram 4 + mrzplace ( type size ) ( R: offset ) + \ adr of first byte behind partition + r@ >nvram over + ( type size adr' ) ( R: offset ) + \ clear first byte behind new partition + dup nvram-size >nvram < IF ( type size adr' ) ( R: offset ) + 0 swap rb! ( type size ) ( R: offset ) + ELSE + drop ( type size ) ( R: offset ) + THEN + \ write size + 10 / r@ >nvram 2+ rw! ( type ) ( R: offset ) + \ write type + dup r@ >nvram rb! ( type ) ( R: offset ) + \ write checksum + r@ calc-header-cksum ( type cksum ) ( R: offset) + r> >nvram 1+ rb! ( type ) + \ zero out partition + get-header drop 0 rfill ( ) +; + +: calc-used-nvram-space ( -- used ) + 0 dup >r BEGIN ( offset ) ( R: used ) + dup >nvram rb@ ( offset sig ) ( R: used ) + WHILE + dup >nvram 2+ rw@ 10 * ( offset length ) ( R: used ) + r> + >r ( offset ) ( R: used ) + dup >nvram 2+ rw@ 10 * ( offset length ) ( R: used ) + + ( offset' ) ( R: used ) + REPEAT + drop r> ( used ) +; + +: create-default-headers + s" Creating common NVRAM partition" nvramlog-write-string-cr + 70 1000 s" common" create-header ( ) + \ calculate free partition + nvram-size calc-used-nvram-space - ( free ) + dup 1 < IF ( free ) + drop ( ) + ELSE + s" Creating free space NVRAM partition with 0x" nvramlog-write-string + dup 6 nvramlog-write-number ( free ) + s" bytes" nvramlog-write-string-cr + 7f swap ( 7f type ) + here 10 allot ( 7f type adr ) + 10 0 DO + dup i + FF swap c! ( 7f type adr ) + LOOP + e create-header ( ) + THEN +; + +: reset-nvram ( -- ) + nvram-base nvram-size 0 rfill ( ) + 51 20000 s" ibm,BE0log" create-header ( ) + 51 5000 s" ibm,BE1log" create-header ( ) + nvram-base 10 + dup ( adr adr ) + 1 swap x! ( adr ) + 40 swap w! ( ) + 20000 nvram-base + 10 + dup ( adr adr ) + 1 swap x! ( adr ) + 40 swap w! ( ) + create-default-headers ( ) +; + +: type-no-zero ( addr len -- ) + 0 do dup i + dup rb@ 0= IF drop ELSE 1 rtype THEN loop drop ; + +: .dmesg ( base-addr -- ) dup 14 + rl@ dup >r + ( base-addr act-off ) ( R: act-off ) + over over over + swap 10 + rw@ + >r + ( base-addr act-off ) ( R: act-off nvram-act-addr ) + over 2 + rw@ 10 * swap - over swap + ( base-addr base-addr start-size ) ( R: act-off nvram-act-addr ) + r> swap rot 10 + rw@ - cr type-no-zero + ( base-addr ) ( R: act-off ) + dup 10 + rw@ + r> type-no-zero ; + + +: type-no-zero-part ( from-str cnt-str addr len ) + 0 do + dup i + dup 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 + THEN + + 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-part ( from-str cnt-str base-addr -- ) dup 14 + l@ dup >r + ( base-addr act-off ) ( R: act-off ) + over over over + swap 10 + w@ + >r + ( base-addr act-off ) ( R: act-off nvram-act-addr ) + over 2 + w@ 10 * swap - over swap + ( base-addr base-addr start-size ) ( R: act-off nvram-act-addr ) + r> swap rot 10 + w@ - cr + rot 4 roll 4 roll 4 roll 4 roll + ( base-addr from-str cnt-str addr len ) + type-no-zero-part rot + ( base-addr ) ( R: act-off ) + dup 10 + w@ + r> type-no-zero-part ; + +: dmesg-part ( from-str cnt-str -- from-str cnt-str ) + 2dup nvram-base .dmesg-part nip nip ; + +: dmesg ( -- ) nvram-base .dmesg ; + +: dmesg2 ( -- ) nvram-log-be1-base .dmesg ; diff --git a/slof/fs/packages.fs b/slof/fs/packages.fs new file mode 100644 index 0000000..3b222be --- /dev/null +++ b/slof/fs/packages.fs @@ -0,0 +1,62 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..3ee48a0 --- /dev/null +++ b/slof/fs/packages/bulk.fs @@ -0,0 +1,87 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..92b4862 --- /dev/null +++ b/slof/fs/packages/deblocker.fs @@ -0,0 +1,61 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..08761fd --- /dev/null +++ b/slof/fs/packages/disk-label.fs @@ -0,0 +1,265 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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" disk-label" device-name + +INSTANCE VARIABLE partition +INSTANCE VARIABLE part-offset +INSTANCE VARIABLE block-size +INSTANCE VARIABLE block +INSTANCE VARIABLE args +INSTANCE VARIABLE args-len + +INSTANCE VARIABLE block# \ variable to store logical sector# +INSTANCE VARIABLE hit# \ partition counter +INSTANCE VARIABLE success-flag +0ff constant END-OF-DESC +3 constant PARTITION-ID +48 constant VOL-PART-LOC + +: seek lxjoin part-offset @ + xlsplit s" seek" $call-parent ; +: read s" read" $call-parent ; + +: init-block ( -- ) + s" block-size" ['] $call-parent CATCH IF ABORT" no block-size" THEN + block-size ! + block-size @ alloc-mem dup block-size @ erase block ! ; + +: parse-partition ( -- okay? ) + 0 part-offset ! 0 partition ! my-args args-len ! args ! + + \ Fix up the "0" thing yaboot does. + args-len @ 1 = IF args @ c@ [char] 0 = IF 0 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 args-len ! 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. + partition ! true ; + +: try-dos-partition ( -- okay? ) + partition @ 1 5 within 0= IF cr ." Partition # not 1-4" false EXIT THEN + + \ Read partition table. + 0 0 seek drop block @ block-size @ read drop + block @ 1fe + 2c@ bwjoin aa55 <> IF cr ." No partitions" false EXIT THEN + + \ Could/should check for valid partition here... aa55 is not enough really. + + \ Get the partition offset. + partition @ 10 * 1b6 + block @ + 4c@ bljoin block-size @ * part-offset ! + true ; + +\ 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 and read starting from 16th sector: + 10 800 * 0 seek drop + block @ block-size @ read drop + \ Check for CD-ROM volume magic: + block @ c@ 1 = + block @ 1+ 5 s" CD001" str= + and +; + + +: try-dos-files ( -- found? ) + block @ 1fe + 2c@ bwjoin aa55 <> IF false EXIT THEN + block @ c@ e9 <> IF + block @ c@ eb <> block @ 2+ c@ 90 <> or IF false EXIT THEN THEN + s" fat-files" find-package IF args @ args-len @ rot interpose THEN true +; + +CREATE ext2-magic 2 allot +: try-ext2-files ( -- found? ) + 438 0 seek drop ext2-magic 2 read drop + ext2-magic w@-le ef53 <> IF false EXIT THEN + s" ext2-files" find-package IF args @ args-len @ rot interpose THEN true +; + +: try-iso9660-files + \ seek and read starting from 16th sector for volume descriptors + block @ 1+ 5 s" CD001" str= + IF \ found ISO9660 signature + s" iso-9660" find-package IF args @ args-len @ rot interpose THEN + TRUE + ELSE + FALSE + THEN +; + + +: try-files ( -- found? ) + \ If no path, then full disk. + args-len @ 0= IF true EXIT THEN + + 0 0 seek drop + block @ block-size @ read drop + try-dos-files IF true EXIT THEN + try-ext2-files IF true EXIT THEN + + \ Seek to the begining of logical 2048-byte sector 16 + \ refer to Chapter C.11.1 in PAPR 2.0 Spec + 10 800 * 0 seek drop + block @ block-size @ read drop + 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 ; + +: open + init-block + parse-partition 0= IF + false EXIT + THEN + partition @ 0= IF + try-files EXIT + THEN + try-partitions +; + +: close + block @ block-size @ free-mem ; + +\ Workaround for not having "value" variables yet. +: block-size block-size @ ; + +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 + + +\ Load from first active DOS boot partition. +\ Note: sector block size is always 512 bytes for DOS partition tables. + +: load-from-dos-boot-partition ( addr -- size ) + 0 0 seek drop + block @ 200 read drop + \ Check for DOS partition table magic: + block @ 1fe + 2c@ bwjoin aa55 <> IF FALSE EXIT THEN + \ Now step through the partition table: + block @ 1be + ( addr part-off ) + 4 0 DO + dup part-entry>active c@ 80 = ( addr part-off active? ) + over part-entry>id c@ 41 = and IF ( addr part-off ) + dup part-entry>sector-offset 4c@ bljoin ( addr part-off sect-off ) + \ seek to the boot partition + 200 * 0 seek drop ( addr part-off ) + part-entry>sector-count 4c@ bljoin ( addr sect-count ) + 200 * read ( size ) + UNLOOP EXIT + THEN + /partition-entry + ( addr part-off ) + LOOP + 2drop 0 +; + +: 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. + +: 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. + +: 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 ) +; + + +\ Boot & Load w/o arguments is assumed to be boot from boot partition + +: load ( addr -- size ) + 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..d33f0e6 --- /dev/null +++ b/slof/fs/packages/ext2-files.fs @@ -0,0 +1,140 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..07c0f7e --- /dev/null +++ b/slof/fs/packages/fat-files.fs @@ -0,0 +1,187 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..c32c84c --- /dev/null +++ b/slof/fs/packages/filler.fs @@ -0,0 +1,21 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..7927381 --- /dev/null +++ b/slof/fs/packages/iso-9660.fs @@ -0,0 +1,307 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..0e3b35d --- /dev/null +++ b/slof/fs/packages/obp-tftp.fs @@ -0,0 +1,55 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + 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 + + r> r> over IF s" bootpath" set-chosen ELSE 2drop THEN + r> r> over IF s" bootargs" set-chosen ELSE 2drop THEN +; + +: 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..2a93e0a --- /dev/null +++ b/slof/fs/packages/rom-files.fs @@ -0,0 +1,85 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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/scsi.fs b/slof/fs/packages/scsi.fs new file mode 100644 index 0000000..3d40700 --- /dev/null +++ b/slof/fs/packages/scsi.fs @@ -0,0 +1,183 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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" scsi" device-name + + +\ Standard Open Firmware method + +: open true ; + + +\ Standard Open Firmware method + +: close ; + + +\ Temporary pointer to SCSI command area + +0 VALUE command + + +\ Temporary pointer to SCSI response Buffer + +0 VALUE response + + +\ Builds SCSI READ command in the buffer +\ This method will take starting Address as an input + +: build-read ( address lba #blocks -- ) + 2 pick to command + command 0c erase + dup 7fff < IF + \ Use READ (10) command - understood by all devices + 28 command c! ( address lba #blocks ) + command 7 + w! ( address lba ) \ Set transfer length + command 2 + l! ( address ) \ Set logical block address + ELSE + \ Use READ (12) command - needed for large #blocks + A8 command c! ( address lba #blocks ) + command 2 + l! ( address lba ) \ Set transfer length + command 6 + l! ( address ) \ Set logical block address + THEN + drop +; + + +\ Builds SCSI MODE-SENSE command in the Buffer +\ This method will take the starting address as an input + +: build-mode-sense ( address alloc-len page-code page-control -- ) + 3 pick to command ( address alloc-len page-code page-control ) + command 0c erase ( address alloc-len page-code page-control ) + 6 lshift or command 2 + c! ( address alloc-len ) + swap 7 + w! \ Configure allocation length +; + + +\ Builds READ CAPACITY command in the buffer + +: build-read-capacity ( address -- ) + TO command + command 0c erase \ Clear buffer + 25 command c! \ set Opcode +; + + +\ Builds SCSI TEST-UNIT-READY command in the Buffer +\ This method will take the starting address as an input + +: build-test-unit-ready ( address -- ) TO command command 0c erase ; + + +\ Builds SCSI INQUIRY command in the Buffer +\ This method will take the starting address as an input + +: build-inquiry ( address alloc-len -- ) + swap TO command ( alloc-len ) + command 0c erase ( alloc-len ) + command 4 + c! \ Set allocation length + 12 command c! \ set Opcode +; + + +\ Analyse response of build-inquiry command + +: return-inquiry ( address -- verson peripheral-type ) + TO response + response 3 + c@ 4 rshift ( version# ) \ SCSI version num + response c@ ( version# peripheral-device-type ) +; + + +\ Builds SCSI REQUEST-SENSE command in the Buffer +\ This method will take the starting address as an input + +: build-request-sense ( address alloc-len -- ) + swap TO command ( alloc-len ) + command 0c erase ( alloc-len ) + 03 command c! ( alloc-len) + command 4 + c! \ Configure the allocation length +; + + +\ Analyse reply of REQUEST-SENSE command in the Buffer +\ This method will take Starting address as an input + +: return-request-sense ( address -- false|ascq asc sense-key true ) + TO response + response c@ 71 + = response c@ 70 = or IF ( TRUE | FALSE ) + response 0D + c@ ( ASCQ ) \ additional sense code qualifier + response 0c + c@ ( ASCQ ASC) \ additional sense code + response 2 + c@ ( ASCQ ASC sense-key ) \ sense key error descriptor + TRUE ( ASCQ ASC sense-key TRUE ) + ELSE + FALSE ( FALSE ) + THEN +; + + +\ Builds SCSI SEEK command in the Buffer +\ This method will take the starting address as an input + +: build-seek ( address lba -- ) + swap TO command ( lba ) + command 0c erase ( lba ) + 2b command c! ( lba ) \ Configure the Opcode + command 2 + l! \ Configure the logical block address +; + + +\ Builds SCSI LOAD command in the Buffer +\ This method will take the starting address as an input + +\ : build-load ( address -- ) +\ TO command +\ command 0c erase +\ 1b command c! \ Cofigure opcode +\ 03 command 4 + c! \ configure load bit and start bit +\ ; + + +\ Builds SCSI UNLOAD command in the Buffer +\ This method will take the starting address as an input + +\ : build-unload ( address -- ) +\ to command +\ command 0c erase +\ 1b command c! \ Configure Opcode +\ 02 command 4 + c! \ Configure unload bit and start bit +\ ; + + +\ Builds SCSI START command in the Buffer +\ This method will take the starting address as an input + +: build-start ( address -- ) + TO command + command 0c erase + 1b command c! \ Configure Opcode + 01 command 4 + c! +; + + +\ Builds SCSI STOP command in the Buffer +\ This method will take the starting address as an input + +: build-stop ( address -- ) + TO command + command 0c erase + 1b command c! \ Configure Opcode +; + diff --git a/slof/fs/packages/sms.fs b/slof/fs/packages/sms.fs new file mode 100644 index 0000000..7df46c0 --- /dev/null +++ b/slof/fs/packages/sms.fs @@ -0,0 +1,34 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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" sms.fs" romfs-lookup [IF] + drop + + 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 +[THEN] + diff --git a/slof/fs/pci-bridge.fs b/slof/fs/pci-bridge.fs new file mode 100644 index 0000000..140f37a --- /dev/null +++ b/slof/fs/pci-bridge.fs @@ -0,0 +1,62 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..a511c41 --- /dev/null +++ b/slof/fs/pci-class-code-names.fs @@ -0,0 +1,263 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..e8d1f49 --- /dev/null +++ b/slof/fs/pci-config-bridge.fs @@ -0,0 +1,85 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..c8b445e --- /dev/null +++ b/slof/fs/pci-device.fs @@ -0,0 +1,101 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..aab8f13 --- /dev/null +++ b/slof/fs/pci-properties.fs @@ -0,0 +1,650 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..e0cd813 --- /dev/null +++ b/slof/fs/pci-scan.fs @@ -0,0 +1,494 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 Line +: 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..5bab531 --- /dev/null +++ b/slof/fs/preprocessor.fs @@ -0,0 +1,41 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 index 16ea308..d8b97ac 100644 --- a/slof/fs/property.fs +++ b/slof/fs/property.fs @@ -1,29 +1,36 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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. - -\ Words on the property list for a package are actually executable words, +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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. -: encode-int here swap lbsplit c, c, c, c, /l ; -: encode-bytes dup >r here >r bounds ?DO i c@ c, LOOP r> r> ; -: encode-string encode-bytes 0 c, char+ ; +\ Put the type as byte before the property +\ { int = 1, bytes = 2, string = 3 } +\ This is used by .properties for pretty print -: encode+ nip + ; -: encode-int+ encode-int encode+ ; +\ 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 -- ) @@ -32,36 +39,151 @@ : prune ( name len -- ) last (prune) ; : set-property ( data dlen name nlen phandle -- ) - get-current >r pkg>properties @ set-current - 2dup prune $2CONSTANT r> set-current ; -: property ( data dlen name nlen -- ) current-package @ set-property ; -: get-property ( str len phandle -- false | data dlen true ) - pkg>properties @ voc-find dup IF link> execute true THEN ; + 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 +; -\ Print out properties. Just a hexdump, nothing fancy for strings etc. : .propbytes ( xt -- ) - execute bounds ?DO space i c@ 2 0.r LOOP ; + execute dup + IF + over cell- @ execute + ELSE + 2drop + THEN +; : .property ( lfa -- ) - cr link> dup >name name>string type space .propbytes ; + 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 -- ) - pkg>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ; + node>properties @ cell+ @ BEGIN dup WHILE dup .property @ REPEAT drop ; : .properties ( -- ) - current-package @ (.properties) ; + get-node (.properties) ; : next-property ( str len phandle -- false | str' len' true ) ?dup 0= IF device-tree @ THEN \ XXX: is this line required? - pkg>properties @ + 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 ; -: full-name encode-string s" full_name" property ; - -\ Getting basic info about a package. -: pkg>name dup >r s" name" rot get-property IF 1- r> drop ELSE r> (u.) THEN ; -: pkg>path dup >r s" full_name" rot get-property drop 1- r> drop ; diff --git a/slof/fs/quiesce.fs b/slof/fs/quiesce.fs new file mode 100644 index 0000000..7521d1c --- /dev/null +++ b/slof/fs/quiesce.fs @@ -0,0 +1,48 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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= IF ( xt arrayptr ) + ! UNLOOP EXIT + ELSE + drop ( xt ) + THEN + LOOP + ." 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..aafc2f6 --- /dev/null +++ b/slof/fs/rmove.fs @@ -0,0 +1,53 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..29fa80d --- /dev/null +++ b/slof/fs/romfs.fs @@ -0,0 +1,123 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +\ ****************************************************************************/ + +eregs 10 8 * + @ CONSTANT romfs-base + +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 ; + +: check-for-board-romfs ( -- true | false ) + s" header" romfs-lookup drop @ + 6d61676963313233 <> IF false ELSE true 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 @ ; + +: flash-header ( -- address | false ) + check-for-board-romfs 0= IF false ELSE + s" header" romfs-lookup 0= IF 0 THEN THEN ; + +CREATE bdate-str 10 allot +: bdate2human ( -- addr len ) + flash-header 40 + @ (.) + 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..67df811 --- /dev/null +++ b/slof/fs/root.fs @@ -0,0 +1,57 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..54aac7b --- /dev/null +++ b/slof/fs/rtas/rtas-cpu.fs @@ -0,0 +1,39 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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@ +; + +: rtas-freeze-timebase ( -- status ) + [ s" freeze-time-base" 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@ +; + +: rtas-thaw-timebase ( -- status ) + [ s" thaw-time-base" 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-flash.fs b/slof/fs/rtas/rtas-flash.fs new file mode 100644 index 0000000..fb4bc6e --- /dev/null +++ b/slof/fs/rtas/rtas-flash.fs @@ -0,0 +1,46 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..c98fe6d --- /dev/null +++ b/slof/fs/rtas/rtas-init.fs @@ -0,0 +1,121 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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" + hsprg1 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..c20f80e --- /dev/null +++ b/slof/fs/rtas/rtas-reboot.fs @@ -0,0 +1,33 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..2191ee9 --- /dev/null +++ b/slof/fs/rtas/rtas-vpd.fs @@ -0,0 +1,33 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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/search.fs b/slof/fs/search.fs index bacf53b..2255636 100644 --- a/slof/fs/search.fs +++ b/slof/fs/search.fs @@ -1,17 +1,18 @@ -\ ============================================================================= -\ * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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: @@ -34,20 +35,22 @@ VARIABLE wordlists forth-wordlist wordlists ! \ \ \ 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 ; +: 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 / ; + 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 ; + clean-hash 1- cells search-order + dup to context + BEGIN dup search-order u>= WHILE + dup >r ! r> cell- REPEAT drop ; \ \ \ @@ -64,24 +67,29 @@ VARIABLE wordlists forth-wordlist wordlists ! \ \ \ Vocabularies \ \ \ -: VOCABULARY ( C: "name" -- ) ( -- ) CREATE wordlist drop - DOES> clean-hash context ! ; +: 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 ! ; -: >name ( xt -- nfa ) - BEGIN char- dup c@ UNTIL - dup dup aligned - cell+ char- - dup >r - BEGIN dup c@ r@ <> WHILE - cell- r> cell+ >r REPEAT r> drop char- ; -: .voc ( wid -- ) \ display name for wid - dup cell- @ ['] vocabulary ['] forth within IF - 2 cells - >name name>string type ELSE u. THEN space ; +\ XXX this one needs to be elsewhere +: >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- ; +: .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 ; + cr wordlists BEGIN @ dup WHILE dup .voc REPEAT drop ; : order ( -- ) - cr ." context: " get-order 0 ?DO .voc LOOP - cr ." current: " get-current .voc ; + cr ." context: " get-order 0 ?DO .voc LOOP + cr ." current: " get-current .voc ; + + + -\ Find word in specific wordlist. -: voc-find ( wid -- 0 | link ) clean-hash cell+ @ (find) clean-hash ; +\ some handy helper +: voc-find ( wid -- 0 | link ) + clean-hash cell+ @ (find) clean-hash ; diff --git a/slof/fs/sms/sms-load.fs b/slof/fs/sms/sms-load.fs new file mode 100644 index 0000000..a5b2541 --- /dev/null +++ b/slof/fs/sms/sms-load.fs @@ -0,0 +1,50 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + +#include "packages/sms.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-start ( -- ) + (sms-init-package) not IF + cr ." SMS is not available." cr exit + THEN + + s" Entering SMS ..." type + disable-watchdog + reset-dual-emit + + \ if we only had execute-device-method... + $sms-node find-device + s" sms-start" evaluate + device-end +; + diff --git a/slof/fs/stack.fs b/slof/fs/stack.fs new file mode 100644 index 0000000..7bbdfb8 --- /dev/null +++ b/slof/fs/stack.fs @@ -0,0 +1,57 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..c36da13 --- /dev/null +++ b/slof/fs/start-up.fs @@ -0,0 +1,85 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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" + +: 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 .banner +; diff --git a/slof/fs/term-io.fs b/slof/fs/term-io.fs new file mode 100644 index 0000000..d352b9e --- /dev/null +++ b/slof/fs/term-io.fs @@ -0,0 +1,57 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + +\ TODO: Implement: ' term-io-key? to key? diff --git a/slof/fs/terminal.fs b/slof/fs/terminal.fs new file mode 100644 index 0000000..e1bf4b2 --- /dev/null +++ b/slof/fs/terminal.fs @@ -0,0 +1,196 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..2184587 --- /dev/null +++ b/slof/fs/timebase.fs @@ -0,0 +1,19 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..954acc1 --- /dev/null +++ b/slof/fs/translate.fs @@ -0,0 +1,152 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..7461440 --- /dev/null +++ b/slof/fs/update_flash.fs @@ -0,0 +1,101 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 move true + ELSE + false + THEN +; + +: flash-read-perm ( -- success? ) + get-flashside 0= IF flash-addr load-base over flash-image-size move 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..a027ec5 --- /dev/null +++ b/slof/fs/usb/usb-enumerate.fs @@ -0,0 +1,257 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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) ( -- ) + mps new-device-address 0 ch-buffer 1 control-std-get-maxlun ( TRUE|FALSE ) + IF + s" GET-MAX-LUN IS WORKING :" usb-debug-print + ELSE + s" ERROR in GET-MAX-LUN " usb-debug-print + 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. + 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" 2 ATAPI " usb-debug-print ENDOF + 05 OF (atapi-8070-create) s" 5 ATAPI " usb-debug-print ENDOF + 06 OF (scsi-create) s" 6 SCSI " 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 +; diff --git a/slof/fs/usb/usb-hub.fs b/slof/fs/usb/usb-hub.fs new file mode 100644 index 0000000..ac0ae66 --- /dev/null +++ b/slof/fs/usb/usb-hub.fs @@ -0,0 +1,468 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +; + + +\ -------------------------------------------------------------------------- +\ 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# -- ) + + \ Step 1: set the Port Power + usb-test-flag + IF + ." Port: " dup . cr + 150 ms \ wait for bad devices + THEN + + dup control-hub-port-power-set drop ( port# ) + 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 + + usb-test-flag + IF + 150 ms + THEN + \ STEP 2: Reset 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 ) + usb-test-flag + IF + s" Port Satus: " status-buffer w@-le usb-debug-print-val + THEN + WHILE ( port# ) + REPEAT ( port# ) + + \ after reset set port enable -important- + dup control-hub-port-enable drop ( port# ) + + usb-test-flag + IF + 10 ms + THEN + + \ 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 + + \ New addition: Sometimes the port status returns connected + \ but Set address was failing. Analysis showed that such + \ ports do not set this bit to 1. + + status-buffer 2 + w@-le 1 and 1 <> ( port# ) + IF ( port# ) + drop + s" No device connected to port- set addresss failed" usb-debug-print + EXIT + THEN + s" HUB: New device found!!!" usb-debug-print +\ s" HUB: Status buffer first word -> " usb-debug-print +\ s" HUB: Status buffer second word -> " usb-debug-print + + \ 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 drop + \ dd-buffer usb-debug-print-val + 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 + s" HUB: Found " usb-debug-print \ temp2 . + s" number of downstream hub ports! : " temp2 usb-debug-print-val + hd-buffer 5 + c@ to po2pg \ get bPwrOn2PwrGood + temp2 1+ 1 DO + 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..ccf1b42 --- /dev/null +++ b/slof/fs/usb/usb-kbd-device-support.fs @@ -0,0 +1,105 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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-protocol drop \ set protocol=boot mode + s" KBDS: Set protocol 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..b0c4be9 --- /dev/null +++ b/slof/fs/usb/usb-keyboard.fs @@ -0,0 +1,345 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + +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 +; + +: open ( -- true ) + true +; + +: close ; + +: 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 +; + +: 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 + \ 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 + 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 + 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 + diff --git a/slof/fs/usb/usb-mouse.fs b/slof/fs/usb/usb-mouse.fs new file mode 100644 index 0000000..1703196 --- /dev/null +++ b/slof/fs/usb/usb-mouse.fs @@ -0,0 +1,26 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 + +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..5b71d56 --- /dev/null +++ b/slof/fs/usb/usb-ohci.fs @@ -0,0 +1,1109 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 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 48 + CONSTANT hcrhdescA +baseaddrs 54 + CONSTANT hcrhpstat + + +\ Constants for COMSTAT register + + +2 CONSTANT CLF + +\ Constants for INTSTAT register + +2 CONSTANT WDH + +\ Constants for RH Port Status Register + +1 CONSTANT RHP-CCS +2 CONSTANT RHP-PES +10 CONSTANT RHP-PRS +100 CONSTANT RHP-PPS +100000 CONSTANT RHP-PRSC + +\ 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 + +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. + +: 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 ) + WHILE ( timeout ) + (HC-CHECK-WDH) ( timeout TRUE|FALSE ) + IF ( timeout ) + drop 0 ( 0 ) + ELSE ( timeout ) + 1- ( timeout ) + 1 ms ( timeout ) + THEN ( timeout ) + + \ Wait for 1 milli-second. + \ PENDING: There should be a better way. + + REPEAT ( timeout ) + drop + hchccadneq rl@-le dup 0<> IF ( td-list ) + TRUE ( td-list TRUE ) + 0 hchccadneq rl!-le ( td-list TRUE ) + (HC-ACK-WDH) ( td-list TRUE ) + ELSE FALSE ( td-list FALSE ) + THEN ( td-list TRUE|FALSE ) +; + + +\ 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 ( -- ) + 00 hccontrol rl!-le + hccomstat dup rl@-le 01 or swap rl!-le + BEGIN + hccomstat rl@-le 01 and 0<> + WHILE + REPEAT + hchcca hchccareg rl!-le + 0000 hcctrhead rl!-le + 0ffff hcintdsbl rl!-le + 0000 hcbulkhead rl!-le + 0083 hccontrol rl!-le + 23f02edf hcintrval rl!-le +; + + +: 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 +; + +\ Fectes 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 ) +; + +\ 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. +\ ========================================================================== + + +VARIABLE total-rh-ports +0 VALUE current-stat + +: rhport-initialize ( total-rh-ports -- ) + total-rh-ports ! + hcrhpstat TO current-stat + total-rh-ports @ 1+ 1 DO + hcrhdescA rl@-le 0300 and 0100 = ( TRUE|FALSE ) + IF + 100 current-stat rl!-le + hcrhdescA 3 + rb@ 2 * ms + THEN + current-stat rl@-le RHP-CCS and 0<> ( TRUE|FALSE ) + IF + s" Device at this port!" usb-debug-print + RHP-PPS current-stat rl!-le \ port power on + hcrhdescA 3 + rb@ 2 * ms \ wait for POTPGT*2 ms + RHP-PES current-stat rl!-le \ port enable + 50 ms + RHP-PRS current-stat rl!-le \ port reset + 50 ms + \ RHP-PRSC current-stat rl!-le + + current-stat rl@-le 200 and 4 lshift + to device-speed \ store speed bit + + 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 + THEN + current-stat 4 + TO current-stat + LOOP +; + + +\ =================================================== +\ Enumeration at Host level +\ =================================================== + +: enumerate ( -- ) + HC-reset + ['] hc-suspend add-quiesce-xt \ Assert that HC will be supsended + hcrhdescA rl@-le 000000ff and ( total-rh-ports ) + 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..0067549 --- /dev/null +++ b/slof/fs/usb/usb-static.fs @@ -0,0 +1,85 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 usb-debug flag to TRUE for debugging output: +0 VALUE usb-debug-flag +0 VALUE usb-test-flag + +\ 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 +; + + +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" rot $cathex strdup \ create alias name + get-node node>path \ get path string + set-alias \ and set the alias +; + +0 VALUE cdrom-alias-num + +\ create a new ohci device alias for the current node: +: set-cdrom-alias ( -- ) + cdrom-alias-num dup 1+ TO cdrom-alias-num ( num ) + s" cdrom" rot $cathex strdup \ create alias name + get-node node>path \ get path string + set-alias \ and set the alias +; + +: 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: ) +; + +\ Scan all USB host controllers for attached devices: +: usb-scan + \ Scan all OHCI chips: + ." Scan USB... " cr + 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 ( -- ) + ELSE + drop ( -- ) + THEN +; diff --git a/slof/fs/usb/usb-storage-support.fs b/slof/fs/usb/usb-storage-support.fs new file mode 100644 index 0000000..5013c2c --- /dev/null +++ b/slof/fs/usb/usb-storage-support.fs @@ -0,0 +1,222 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 ) +; + + +\ --------------------------------------------------------------------------- +\ SCSI support package methods +\ --------------------------------------------------------------------------- + +: build-read ( address lba #blocks -- ) + s" build-read" ihandle-scsi @ $call-method +; + +: build-inquiry ( address alloc-len -- ) + s" build-inquiry" ihandle-scsi @ $call-method +; + +: return-inquiry ( address -- version# peripheral-device-type ) + s" return-inquiry" ihandle-scsi @ $call-method + ( version# peripheral-device-type ) +; + +: build-mode-sense ( address alloc-len page-code page-control -- ) + s" build-mode-sense" ihandle-scsi @ $call-method +; + +: build-read-capacity ( address -- ) + s" build-read-capacity" ihandle-scsi @ $call-method +; + +: build-seek ( address lba -- ) + s" build-seek" ihandle-scsi @ $call-method +; + +: build-start ( address -- ) + s" build-start" ihandle-scsi @ $call-method +; + +: build-stop ( address -- ) + s" build-stop" ihandle-scsi @ $call-method +; + +\ : build-load ( address -- ) +\ s" build-load" ihandle-scsi @ $call-method +\ ; + +\ : build-unload ( address -- ) +\ s" build-unload" ihandle-scsi @ $call-method +\ ; + +: build-test-unit-ready ( address -- ) + s" build-test-unit-ready" ihandle-scsi @ $call-method +; + +: return-test-unit-ready ( address -- status ) + s" return-unit-ready" ihandle-scsi @ $call-method ( status ) +; + +: build-read-toc ( address session# alloc-len -- ) + s" build-read-toc" ihandle-scsi @ $call-method +; + +: build-request-sense ( address alloc-len -- ) + s" build-request-sense" ihandle-scsi @ $call-method +; + +: return-request-sense ( address -- FALSE | ASCQ ASC sense-key TRUE ) + s" return-request-sense" ihandle-scsi @ $call-method + ( FALSE | ASCQ ASC sense-key TRUE ) +; + + +\ ======================================================= +\ 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..eb3d547 --- /dev/null +++ b/slof/fs/usb/usb-storage-wrapper.fs @@ -0,0 +1,181 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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..642e46a --- /dev/null +++ b/slof/fs/usb/usb-storage.fs @@ -0,0 +1,464 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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-scsi +INSTANCE VARIABLE ihandle-deblocker +INSTANCE VARIABLE flag +INSTANCE VARIABLE count +0 VALUE max-transfer +0 VALUE block-size + + +\ ------------------------------------------------------- +\ 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 +: do-bulk-command ( resp-buffer resp-size -- TRUE | FALSE ) + TO resp-size + TO resp-buffer + 2 TO bulk-cnt + 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 + 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 + l@-le + 2 = IF \ Phase Error + s" 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. + 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. Recieve and analyse +\ (pending) INQUIRY data +\ --------------------------------------------------------------- + +: inquiry ( -- ) + s" usb-storage: inquiry" usb-debug-print + command-buffer 1 20 80 lun 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + 20 ( address alloc-len ) + build-inquiry + response-buffer 20 + do-bulk-command + IF + s" Successfully read INQUIRY data" usb-debug-print + s" Inquiry data for 0x20 bytes availabe in Response buffer" + usb-debug-print + ELSE + \ TRUE ABORT" USB device transaction error. (inquiry)" + 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 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + ( address ) + build-read-capacity + response-buffer 8 do-bulk-command + IF + s" Successfully read READ CAPACITY data" usb-debug-print + ELSE + \ TRUE ABORT" USB device transaction error. (capacity)" + 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 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + ( address ) + build-test-unit-ready + 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 +; + +\ ------------------------------------------------- +\ 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 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + 12 ( address alloc-len ) + build-request-sense + response-buffer 12 do-bulk-command + IF + s" Read Sense data successfully" usb-debug-print + 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 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + ( address ) + build-start + 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 0c + ( address tag transfer-len direction lun command-len ) + build-cbw + command-buffer SCSI-COMMAND-OFFSET + ( address ) + build-stop + 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 +\ ------------------------------------------------------------- + +: seek ( pos-hi pos-lo -- status ) + s" seek" ihandle-deblocker @ $call-method +; + + +\ ------------------------------------------------------------- +\ 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 ) + 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# #block command-addr ) + SCSI-COMMAND-OFFSET + -rot ( address command-addr block# #blocks ) + build-read ( address ) + temp1 do-bulk-command + IF + s" Read Sense 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 ) +; + +\ ------------------------------------------------ +\ To bring the the media to seekable and readable +\ condition. +\ ------------------------------------------------ + +0 VALUE temp1 +0 VALUE temp2 +0 VALUE temp3 +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 return-request-sense + ( FALSE | ascq asc sense-key TRUE ) + IF + to temp1 ( ascq asc ) + to temp2 ( ascq ) + to temp3 + temp1 2 = temp2 3a = and ( TRUE | FALSE ) + IF + 5010 error" (USB) No Media found! Check for the drawer/inserted media." + ABORT + THEN + temp1 2 = temp2 06 = and ( TRUE | FALSE ) + IF + 5020 error" (USB) Unknown media format." + ABORT + THEN + temp1 0<> temp2 4 = temp3 2 = and and ( TRUE | FALSE ) + IF + start stop + THEN + THEN + THEN + d# 10 ms + REPEAT + usb-debug-flag IF + ." make-media-ready finished after " + count @ decimal . hex ." tries." cr + THEN +; + + +\ 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 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) + ihandle-scsi s" scsi" (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-scsi (close-package) + ihandle-bulk (close-package) +; + + +\ Set device name according to type + +: (init-device-name) ( -- ) + inquiry + response-buffer c@ + CASE + 1 OF s" tape" device-name ENDOF + 5 OF s" cdrom" device-name ENDOF + \ dup OF s" storage" device-name ENDOF + ENDCASE +; + + +\ Initial device node setup + +: (initial-setup) + ihandle-bulk s" bulk" (open-package) + ihandle-scsi s" scsi" (open-package) + + device-init + (init-device-name) + set-cdrom-alias + 200 to block-size \ Default block-size, will be overwritten in "open" + 10000 to max-transfer + + ihandle-bulk (close-package) + ihandle-scsi (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..1326a04 --- /dev/null +++ b/slof/fs/usb/usb-support.fs @@ -0,0 +1,628 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 ) + \ s" controlxfer: Allocated ED: " temp1 usb-debug-print-val + 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. + + +: (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 BEGIN ( ed-ptr ) + td-retire-count num-tds <> ( ed-ptr TRUE | FALSE ) + poll-timer d# 5000 < and ( ed-ptr TRUE | FALSE ) + WHILE + (HC-CHECK-WDH) IF ( ed-ptr ) + hchccadneq rl@-le find-td-list-tail-and-size nip ( ed-ptr n ) + td-retire-count + TO td-retire-count ( ed-ptr ) + hchccadneq rl@-le dup ( ed-ptr done-td done-td ) + (td-list-status) IF ( ed-ptr done-td failed-td CCcode ) + \ 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 IF ( ed-ptr done-td failed-td CCcode R: CCcode ) + d# 5000 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 rl!-le ( ed-ptr ) + (HC-ACK-WDH) \ TDs were written to DOne queue. ACK the HC. + \ s" Retired = " td-retire-count usb-debug-print-val + \ s" Total = " num-tds usb-debug-print-val + THEN + poll-timer 1+ TO poll-timer + 1 ms + REPEAT ( ed-ptr ) + disable-control-list-processing ( ed-ptr ) + td-retire-count num-tds <> IF ( ed-ptr ) + dup display-descriptors ( ed-ptr ) + 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) IF ( TD-list ) + 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) IF ( td-list failed-TD CC ) + dup 4 = IF + saved-list-type CASE + 0 OF 0 0 control-std-clear-feature + ENDOF + 1 OF \ clean bulk stalled + 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 + ENDCASE + ELSE + usb-debug-flag IF + s" TD failed with CC code: " type . cr + THEN + drop drop + \ TRUE ABORT" USB device transaction error." + 5040 error" (USB) device transaction error." + ABORT + THEN + 2drop drop + TRUE TO while-failed \ transaction failed + NEXT-TD 0<> IF \ clean the TD if we + NEXT-TD (free-td-list) \ had a stalled + THEN + THEN + (free-td-list) + ELSE + drop \ drop td-list pointer + TRUE TO while-failed + 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 + ELSE + 0 + THEN + 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..50c3cac --- /dev/null +++ b/slof/fs/vpd-bootlist.fs @@ -0,0 +1,83 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2007 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 +\ ****************************************************************************/ + +: 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 ELSE true THEN ; + +\ the following words are necessary for vpd-boot-import +defer set-boot-device +defer add-boot-device +defer bootdevice + +\ 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 + 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 + s" net" furnish-boot-file $cat strdup add-boot-device + ENDOF + + \ 7 OF cr s" Booting from no device not supported" 2dup mm-log-warning log-string cr + \ 7 OF cr s" 2B Booting from NVRAM boot-device list: " boot-device $cat + \ log-string cr + \ boot-device add-boot-device ENDOF + + 8 OF \ cr s" 2B Booting from disk0" log-string cr + s" disk disk0" add-boot-device ENDOF + + 9 OF \ cr s" 2B Booting from disk1" log-string cr + s" disk1" add-boot-device ENDOF + + A OF \ cr s" 2B Booting from disk2" log-string cr + s" disk2" add-boot-device ENDOF + + B OF \ cr s" 2B Booting from disk3" log-string cr + s" disk3" add-boot-device ENDOF + + C OF \ cr s" 2B Booting from CDROM" log-string cr + s" cdrom" add-boot-device ENDOF + + E OF \ cr s" 2B Booting from disk4" log-string cr + s" disk4" add-boot-device ENDOF + + F OF \ cr s" 2B Booting from SAS - w. Timeout" log-string cr + s" sas" add-boot-device ENDOF + 10 OF \ cr s" 2B Booting from SAS - Continuous Retry" log-string cr + s" sas" add-boot-device ENDOF + ENDCASE + LOOP + bootdevice 2@ dup >r s" boot-device" $setenv + r> IF 0 ELSE -6b THEN + ELSE -6a THEN + boot-exception-handler +; diff --git a/slof/lowmem.S b/slof/lowmem.S new file mode 100644 index 0000000..024e78f --- /dev/null +++ b/slof/lowmem.S @@ -0,0 +1,67 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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 @@ -1,88 +1,112 @@ -# ============================================================================= -# * Copyright (c) 2004, 2005 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 loader. This is position-independent code. -# +/****************************************************************************** + * Copyright (c) 2004, 2007 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> .section ".slof.loader","ax" -. = 0 - - # Get our address. - - bcl 20,31,$+4 - mflr 31 - - # Copy exception vectors. - - addi 1,31,0x200-4-8 - li 0,0x3f00/8 - mtctr 0 - li 2,0x100-8 + # get our address + +.base: + bcl 20,31,0f + .align 3 +.st: .quad _slof_text-.base +.stl: .quad _slof_text_size +.sd: .quad _slof_data-.base +.sdl: .quad _slof_data_size +.sbl: .quad _slof_bss_size +0: + mr r16,r3 # ROM Base + mfspr r17, HSPRG1 # Fixme, will be done in pcd + mflr r31 + subi r31,r31,4 + + # copy paflof text + + ld r3,.st-.base(r31) + add r3,r3,r31 + lis r4,_slof_text@h # Addr of engine code + ori r4,r4,_slof_text@l + ld r5,.stl-.base(31) + bl .copy + + lis r3,_slof_text@h # Addr of engine code + ori r3,r3,_slof_text@l + ld r4,.stl-.base(r31) + bl .flush + + # copy paflof data + + ld r3,.sd-.base(31) + add r3,r3,r31 + lis r4,_slof_data@h # Addr of engine data + ori r4,r4,_slof_data@l + ld r5,.sdl-.base(r31) + bl .copy + + lis r3,_slof_data@h # Addr of engine data + ori r3,r3,_slof_data@l + ld r4,.sdl-.base(r31) + bl .flush + + # zero paflof bss + + lis r3,_slof_bss@h # Addr of engine bss + ori r3,r3,_slof_bss@l + ld r4,.sbl-.base(r31) + bl .zero + + lis r3,_slof_bss@h # Addr of engine bss + ori r3,r3,_slof_bss@l + ld r4,.sbl-.base(r31) + bl .flush + + # fill in handler address + + lis r3,_slof_text@h + ori r3,r3,_slof_text@l + ld r3,0(r3) + std r3,0x2ff0(0) + + # GO! + + ba 0x100 + + +.zero: # zero from r3 size r4 + subi r3,r3,8 + addi r4,r4,7 + srwi r4,r4,3 + mtctr r4 + li r5,0 0: - ldu 0,8(1) - stdu 0,8(2) - bdnz 0b + stdu r5,8(r3) + bdnz 0b - # Copy Paflof text. + blr - addi 1,31,0x4100-4-8 - li 0,0x2000/8 - mtctr 0 - lis 2,0x111 - subi 2,2,8 +.copy: # copy from 3 to 4 size 5 + subi r3,r3,8 + subi r4,r4,8 + addi r5,r5,7 + srwi r5,r5,3 + mtctr r5 0: - ldu 0,8(1) - stdu 0,8(2) - bdnz 0b - - # Copy paflof data. - - addi 1,31,0x6100-4-8 - lis 0,1 - mtctr 0 - lis 2,0x112 - subi 2,2,8 -0: - ldu 0,8(1) - stdu 0,8(2) - bdnz 0b - - # Flush L1-D cache. - - sync - - # Flush L1-I cache for Paflof and exception vector code. - - li 0,0x4000/128 - mtctr 0 - li 1,0 -0: - icbi 0,1 - addi 1,1,128 - bdnz 0b - - li 0,0x2000/128 - mtctr 0 - lis 1,0x111 -0: - icbi 0,1 - addi 1,1,128 - bdnz 0b - - isync + ldu r5,8(r3) + stdu r5,8(r4) + bdnz 0b - # Go! + blr - ba 0x100 +.flush: # flush at 3 size 4 + FLUSH_CACHE(r3, r4) + blr diff --git a/slof/paflof.c b/slof/paflof.c index 3f193da..b25f294 100644 --- a/slof/paflof.c +++ b/slof/paflof.c @@ -1,20 +1,19 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 @@ -22,22 +21,38 @@ #include "paflof.h" #include ISTR(TARG,h) -void engine(long error) +#define LAST_ELEMENT(x) x[sizeof x / sizeof x[0] - 1] + +#include ISTR(TARG,c) + + +void engine(long error, long reason) { cell *restrict dp; cell *restrict rp; cell *restrict ip; cell *restrict cfa; - cell handler_stack[16]; + cell handler_stack[160]; - #include "prim.h" + #include "prep.h" #include "dict.xt" + static int init_lw = 0; + if (init_lw == 0) { + init_lw = 1; + LAST_ELEMENT(xt_FORTH_X2d_WORDLIST).a = xt_LASTWORD; + } + dp = the_data_stack; rp = handler_stack - 1; + if (error != 0x100) { + dp->n = reason; + dp++; + } dp->n = error; ip = xt_SYSTHROW; #include "prim.code" + #include "board.code" #include ISTR(TARG,code) } diff --git a/slof/paflof.h b/slof/paflof.h index ea6dbfc..cf2f07f 100644 --- a/slof/paflof.h +++ b/slof/paflof.h @@ -1,53 +1,18 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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> // -#include "types.h" #define TIBSIZE 256 #define POCKETSIZE 256 - -// Where we put the exception save areas, and the stacks. -// Stacks grow upwards, just like in real life. You should see my desk. -#define the_exception_frame ((cell *)0x1100000) -#define the_client_frame ((cell *)0x1100400) -#define the_data_stack ((cell *)0x1102000) -#define the_return_stack ((cell *)0x1104000) -#define the_system_stack ((cell *)0x1106000) - -// These buffers are allocated in C code to ease implementation. -#define the_tib ((cell *)0x1108000) -#define the_pockets ((cell *)0x1109000) - -// This is where the run-time data space starts. -#define the_mem ((cell *)0x1200000) - - -// Some binary blob that is linked in to the image. Use an ELF file -// for example; we can execute that as a client program, then. -// You could use yaboot or a (small enough) Linux kernel, for example. -extern char _binary_payload_start[]; - -// Assembler glue routine for switching context between the client -// program and SLOF itself. -extern void client_entry_point(); -extern unsigned long call_client(cell); - -// Magic function to perform stuff that we don't give source for. -extern type_u oco(cell, cell); - -// Synchronize instruction cache with data cache. -extern void flush_cache (void*, long); diff --git a/slof/ppc64.c b/slof/ppc64.c new file mode 100644 index 0000000..6fdad05 --- /dev/null +++ b/slof/ppc64.c @@ -0,0 +1,39 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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> + +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", "r31"); + + return r3; +} + +long +writeLogByte_wrapper(long x, long y) +{ + unsigned long result; + set_ci(); + result = writeLogByte(x, y); + clr_ci(); + return result; +} diff --git a/slof/ppc64.code b/slof/ppc64.code index 1fe1d2f..e2866fb 100644 --- a/slof/ppc64.code +++ b/slof/ppc64.code @@ -1,34 +1,19 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. -// Set and clear the RM_CI bit in HID4. Needed for all I/O accesses. -#define SET_CI do { \ - unsigned long hid4; \ - asm volatile("mfspr %0,1012" : "=r"(hid4)); \ - hid4 |= 0x0000010000000000UL; \ - asm volatile("slbia ; sync ; mtspr 1012,%0 ; isync" : "+r"(hid4)); \ -} while (0) - -#define CLR_CI do { \ - unsigned long hid4; \ - asm volatile("mfspr %0,1012" : "=r"(hid4)); \ - hid4 &= ~0x0000010000000000UL; \ - asm volatile("sync ; mtspr 1012,%0 ; isync" : "+r"(hid4)); \ -} while (0) - // 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 @@ -36,6 +21,8 @@ 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) @@ -51,7 +38,7 @@ MIRP PRIM(HID1_X21) unsigned long hid1 = TOS.u; - asm volatile("mtspr 1009,%0 ; mtspr 1009,%0 ; isync" : "+r"(hid1)); + asm volatile("mtspr 1009,%0 ; mtspr 1009,%0 ; isync" : : "r"(hid1)); POP; MIRP @@ -62,7 +49,7 @@ MIRP PRIM(HID4_X21) unsigned long hid4 = TOS.u; - asm volatile("sync ; mtspr 1012,%0 ; isync" : "+r"(hid4)); + asm volatile("sync ; mtspr 1012,%0 ; isync" : : "r"(hid4)); POP; MIRP @@ -73,7 +60,7 @@ MIRP PRIM(HID5_X21) unsigned long hid5 = TOS.u; - asm volatile("mtspr 1014,%0" : "+r"(hid5)); + asm volatile("mtspr 1014,%0" : : "r"(hid5)); POP; MIRP @@ -85,7 +72,7 @@ MIRP // PowerPC special registers. PRIM(MSR_X21) unsigned long msr = TOS.u; - asm volatile("mtmsrd %0" : "+r"(msr)); + asm volatile("mtmsrd %0" : : "r"(msr)); POP; MIRP @@ -96,7 +83,7 @@ MIRP PRIM(SDR1_X21) unsigned long sdr1 = TOS.u; - asm volatile("mtsdr1 %0" : "+r"(sdr1)); + asm volatile("mtsdr1 %0" : : "r"(sdr1)); POP; MIRP @@ -127,7 +114,7 @@ MIRP PRIM(DABR_X21) unsigned long dabr = TOS.u; - asm volatile("mtspr 1013,%0" : "+r"(dabr)); + asm volatile("mtspr 1013,%0" : : "r"(dabr)); POP; MIRP @@ -138,7 +125,7 @@ MIRP PRIM(HIOR_X21) unsigned long dabr = TOS.u; - asm volatile("mtspr 311,%0" : "+r"(dabr)); + asm volatile("mtspr 311,%0" : : "r"(dabr)); POP; MIRP @@ -147,9 +134,78 @@ PRIM(HIOR_X40) 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)); + asm volatile("sync ; mtspr 795,%0 ; isync" : : "r"(mmcr0)); POP; MIRP @@ -158,20 +214,50 @@ PRIM(PMC1_X40) 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 -// Call an object-code only routine. -PRIM(OCO) - cell p0 = TOS; POP; - cell p1 = TOS; - TOS.u = oco(p0, p1); -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 index fa1d10d..eff7383 100644 --- a/slof/ppc64.h +++ b/slof/ppc64.h @@ -1,18 +1,52 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 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_ppc64_fs_start[], _binary_ppc64_fs_end[]; +extern char _slof_start[]; +extern char _slof_here_start[]; + +#define the_exception_frame ((cell *) (_slof_start)) +#define the_client_frame ((cell *) (_slof_start+0x400)) +#define the_data_stack ((cell *) (_slof_start+0x2000)) +#define the_return_stack ((cell *) (_slof_start+0x4000)) +#define the_system_stack ((cell *) (_slof_start+0x6000)) + +// these two really need to be implemented as a plain +// normal BUFFER: in the data space +#define the_tib ((cell *) (_slof_start+0x8000)) +#define the_pockets ((cell *) (_slof_start+0x9000)) +#define the_comp_buffer ((cell *) (_slof_start+0xA000)) +#define the_client_stack ((cell *) (_slof_start+0xBf00)) + +// wasteful, but who cares. 14MB should be enough. +#define the_mem ((cell *) (_slof_here_start)) + +#define the_heap_start ((cell *) (_slof_start+0x700000)) +#define the_heap_end ((cell *) (_slof_start+0x700000+0x800000)) + + +extern char _binary_OF_fsi_start[], _binary_OF_fsi_end[]; +//extern char _binary_vmlinux_start[], _binary_vmlinux_end[]; +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 index 993f096..d7da086 100644 --- a/slof/ppc64.in +++ b/slof/ppc64.in @@ -1,15 +1,14 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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. @@ -20,6 +19,8 @@ cod(RW@) cod(RW!) cod(RL@) cod(RL!) +cod(RX@) +cod(RX!) // CPU register accesses. cod(HID0!) @@ -42,29 +43,61 @@ 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) +//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) -// Calling binary-only code. -cod(OCO) + +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 0x10000000) +var(DAAR 0x00f00000) col(DUMBER DAAR @ C! LIT(1) DAAR +!) -// Engine startup. -col(NICEINIT DOTICK DUMBER DOTO EMIT DOTICK ((FIND)) DOTO (FIND) DOTICK 2DROP DOTO (REVEAL) LIT((type_u)_binary_ppc64_fs_start) LIT((type_u)_binary_ppc64_fs_end) OVER - DOTICK EVALUATE CATCH ?DUP 0BRANCH(2) PRINT-STATUS CLEAR) -static cell xt_SYSTHROW[] = { DUP LIT(0x100) _X3d _0BRANCH(3) DROP NICEINIT QUIT PRINT_X2d_STATUS QUIT }; +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(3) 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 index 1fc7486..e020b6b 100644 --- a/slof/prep.h +++ b/slof/prep.h @@ -1,20 +1,19 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 }, @@ -36,7 +35,7 @@ #define DOBUFFER_X3a lab(DOBUFFER_X3a) #define cod(_xt) def(lab(_xt)) -#define col(_xt, _def...) def(DOCOL _def EXIT) +#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)) diff --git a/slof/prim.code b/slof/prim.code index 7df46fa..c97706a 100644 --- a/slof/prim.code +++ b/slof/prim.code @@ -1,13 +1,15 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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 (c) 2004, 2005 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 // ============================================================================ @@ -15,6 +17,7 @@ // 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 @@ -51,6 +54,22 @@ 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 +PRIM(CISTACK) PUSH; TOS.a = the_client_stack; 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 + // Codefields. @@ -68,12 +87,21 @@ code_DODOES: 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; @@ -86,6 +114,10 @@ code_DOFIELD: NEXT; } code_DOVAR: + { + (++dp)->a = cfa + 1; + NEXT; + } code_DOBUFFER_X3a: { (++dp)->a = cfa + 1; @@ -112,10 +144,22 @@ code_0BRANCH: 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; @@ -146,6 +190,7 @@ 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 @@ -319,6 +364,13 @@ code_EXIT: ip = (rp--)->a; NEXT; } + +code_SEMICOLON: + { + ip = (rp--)->a; + NEXT; + } + code_EXECUTE: // don't need this as prim { cfa = (dp--)->a; @@ -329,21 +381,149 @@ code_EXECUTE: // don't need this as prim // 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; - if (p >= q || q >= p + n) - for (p--, q--; n--; ) - *++q = *++p; - else - for (p += n, q += n ; n--; ) - *--q = *--p; + + _FASTMOVE(p, q, n); MIRP +code_FILL: + { + unsigned char c = (dp--)->u; + int 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; +#ifndef UNIX + 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; + } -PRIM(FLUSHCACHE) - type_u n = TOS.u; POP; - unsigned char* p = TOS.a; POP; - flush_cache(p, n); +code_COMP: + { + int 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; + extern int toupper(int c); + + 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 + diff --git a/slof/prim.in b/slof/prim.in index ff39f95..6da069f 100644 --- a/slof/prim.in +++ b/slof/prim.in @@ -1,13 +1,15 @@ +/****************************************************************************** + * Copyright (c) 2004, 2007 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 (c) 2004, 2005 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 // ============================================================================ @@ -17,9 +19,19 @@ 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) cod(BRANCH) _ADDING _O cod(0BRANCH) _ADDING _O +dfr(BP) +cod(BREAKPOINT) cod(LIT) _ADDING _N cod(DOTICK) @@ -33,6 +45,7 @@ cod(SWAP) cod(>R) cod(R>) cod(R@) +cod(RPICK) cod(DEPTH) cod(DEPTH!) @@ -74,8 +87,13 @@ cod(DOLEAVE) _ADDING _O cod(DO?LEAVE) _ADDING _O cod(EXIT) +cod(SEMICOLON) cod(EXECUTE) cod(MOVE) +// cod(RMOVE64) +cod(RMOVE) + + + -cod(FLUSHCACHE) diff --git a/slof/ref.pl b/slof/ref.pl index 0cfe10a..61f7a88 100644 --- a/slof/ref.pl +++ b/slof/ref.pl @@ -1,33 +1,45 @@ +# ***************************************************************************** +# * Copyright (c) 2004, 2007 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 (c) 2004, 2005 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> # + +use Getopt::Std; use Data::Dumper; $CELLSIZE = length(sprintf "%x", ~0) / 2; -$CELLSIZE = 8; # Hard code for cross-compiling to a different size ABI. +$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; } @@ -36,6 +48,7 @@ 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 $_; @@ -45,23 +58,41 @@ 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 = ''; @@ -70,8 +101,13 @@ while ($line = <>) { $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/; } @@ -84,15 +120,20 @@ while ($line = <>) { $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"; @@ -104,3 +145,4 @@ while ($line = <>) { print $line; } } +$DEBUG and print STDERR "\n"; diff --git a/slof/types.h b/slof/types.h index 7cb2c8d..6f5d146 100644 --- a/slof/types.h +++ b/slof/types.h @@ -1,20 +1,19 @@ -// ============================================================================ -// * Copyright (c) 2004, 2005 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 (c) 2004, 2007 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 @@ -34,6 +33,7 @@ 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 { |