Hi, Nathan Cain <[EMAIL PROTECTED]> writes:
> I was hoping to toy with this some, and start in on adapting an arm > backend... Cool! I'd be more than happy to help with this process, if you need any assistance at all. I think most of it should be relatively straightforward by staring at the patch to CodeGenerator-i386.st. > unfortunately, the patch does not want to apply, as it seems to > expect a different jolt2/boot.k then what is in svn r407. Perhaps I > need another of your patches as well, beyond just jolt2-fixes? > Could you tell me which? Actually, I just described the patch requirements really badly. The idea is: $ svn checkout -r407 ... $ cd idst $ patch -p0 < ../jolt2-fixes.patch $ patch -p0 < ../jolt2-slink.patch I've attached new versions of these patches that fix a few issues (forgot the '{...} grammar syntax in jolt2-fixes.patch, mangle Jolt names that can't be directly expressed in the output) and demonstrates the use of (syntax ...) in function/examples2/slink/main.k. Good luck, -- Michael FIG <[EMAIL PROTECTED]> //\ http://michael.fig.org/ \//
Get jolt2 and examples2 to work. diff -r 2e8939abc3c6 function/examples/cairo/Makefile --- a/function/examples/cairo/Makefile Wed Apr 23 23:45:22 2008 -0600 +++ b/function/examples/cairo/Makefile Fri Apr 25 16:12:38 2008 -0600 @@ -6,7 +6,7 @@ run test : cairolib.so .FORCE $(JOLT) boot.k main.k cairolib.so : cairolib.st - $(IDC) $(CAIROINC) -I../../objects -s $< + $(IDC) -g -k $(CAIROINC) -I../../objects -s $< clean : .FORCE rm -f *~ *.so *.o diff -r 2e8939abc3c6 function/examples/cairo/libcairo.k --- a/function/examples/cairo/libcairo.k Wed Apr 23 23:45:22 2008 -0600 +++ b/function/examples/cairo/libcairo.k Fri Apr 25 16:12:38 2008 -0600 @@ -1,5 +1,4 @@ (dlopen "libcairo") -(define cairolib (dlopen "cairolib")) -((_dlsym cairolib "__id__init__")) +[Object _import: "cairolib"] (define libcairo (import "libcairo")) diff -r 2e8939abc3c6 function/examples/regexp/Makefile --- a/function/examples/regexp/Makefile Wed Apr 23 23:45:22 2008 -0600 +++ b/function/examples/regexp/Makefile Fri Apr 25 16:12:38 2008 -0600 @@ -12,55 +12,55 @@ test1 : .FORCE test1 : .FORCE time egrep 'break|continue|for|while|switch|case|return|static|extern' < tests/test.c | tee out.e | wc -l time $(GREP) 'break|continue|for|while|switch|case|return|static|extern' < tests/test.c | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test2 : .FORCE time egrep 'd?e?l?t?a?' < tests/termcap | tee out.e | wc -l time $(GREP) 'd?e?l?t?a?' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test3 : .FORCE time egrep 'd?e+l*t?a+' < tests/termcap | tee out.e | wc -l time $(GREP) 'd?e+l*t?a+' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test4 : .FORCE time egrep 'd?e+l*t?a+' < tests/termcap | tee out.e | wc -l time $(GREP) 'd?e+l*t?a+' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test5 : .FORCE time egrep 'p[aeiou]t' < tests/termcap | tee out.e | wc -l time $(GREP) 'p[aeiou]t' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test6 : .FORCE time egrep 'p[^aeiou]t' < tests/termcap | tee out.e | wc -l time $(GREP) 'p[^aeiou]t' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test7 : .FORCE time egrep '19[0-9]+' < tests/termcap | tee out.e | wc -l time $(GREP) '19[0-9]+' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test8 : .FORCE time egrep '19[^0-9]+' < tests/termcap | tee out.e | wc -l time $(GREP) '19[^0-9]+' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p test9 : .FORCE time egrep '..a.....b' < tests/termcap | tee out.e | wc -l time $(GREP) '..a.....b' < tests/termcap | tee out.p | wc -l - diff out.e out.p + cmp out.e out.p rm out.e out.p diff -r 2e8939abc3c6 function/jolt2/ColaGrammar.st --- a/function/jolt2/ColaGrammar.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/ColaGrammar.st Fri Apr 25 16:12:38 2008 -0600 @@ -17,6 +17,7 @@ ColaParsingGrammar := [ Grammar new ] at: #comment put: ( '//' parse , (#eol parse not , PeAny) zeroMore , #eol parse); at: #_ put: ( _ := ( (#space parse | #comment parse) zeroMore ) ). g at: #pling put: '!' parse , _; + at: #EXTENDS put: 'EXTENDS:' parse , _; at: #lparen put: '(' parse , _; at: #rparen put: ')' parse , _; at: #query put: '?' parse , _; @@ -67,9 +68,11 @@ ColaParsingGrammar := [ Grammar new ] | ( ( #larrow parse , #number parse <- [:p | ([EMAIL PROTECTED]) <- p result] ->0 ) zeroOne <- [:p | [EMAIL PROTECTED] ) ) ). g at: #sequence put: ( #suffix parse ->0 , ( #suffix parse <- [:p | ([EMAIL PROTECTED]) , p result] ->0 ) zeroMore <- [:p | [EMAIL PROTECTED] ). g at: #expression put: ( #sequence parse ->0 , ( #bar parse , #sequence parse <- [:p | ([EMAIL PROTECTED]) | p result] ->0 ) zeroMore <- [:p | [EMAIL PROTECTED] ). - g at: #grammar put: ( [Grammar new] setResult ->0 + g at: #grammar put: ( [Grammar new] setResult ->0 , _ , ( #identifier parse ->1 , #equal parse , #expression parse , #semicolon parse zeroOne <- [:p | [EMAIL PROTECTED] at: [EMAIL PROTECTED] put: p result] ) zeroMore + , ( #EXTENDS parse , ( ColaFunctionGrammar-#expression ) <- [:p | [EMAIL PROTECTED] extends: p result _eval] , _ ) zeroMore , ( #expression parse <- [:p | [EMAIL PROTECTED] startRule: p result] ) zeroOne + ) <- [:p | ([EMAIL PROTECTED]) finalise "println"]. ] @@ -88,9 +91,9 @@ ColaParsingGrammar := [ Grammar new ] at: #other put: '-+!#$%&*./:<=>[EMAIL PROTECTED]|~' parseClass. g at: #identifier put: ( ( #alpha parse | #other parse ) , ( #alpha parse | #digit parse | #other parse ) zeroMore ) textResult <- [:p | p result asSymbol]. g at: #decimal put: ( #digit parse oneMore textResult <- [:p | p result inject: 0 into: [:n :c | n * 10 + c digitValue]] ); - at: #heximal put: ( ( '0x' parse , ( #digit parse | #hex parse ) oneMore ) textResult <- [:p | p result inject: 0 into: [:n :c | n * 16 + c digitValue]] ); + at: #heximal put: ( '0x' parse , ( ( #digit parse | #hex parse ) oneMore textResult <- [:p | p result inject: 0 into: [:n :c | n * 16 + c digitValue]] ) ); at: #posfloat put: ( #decimal parse -> 0 , '.' parse , ( #digit parse oneMore textResult ) -> 1 <- [:p | ([EMAIL PROTECTED] reverseInject: 0.0 into: [:n :c | n / 10.0 + c digitValue]) / 10.0 + ([EMAIL PROTECTED])] ); - at: #posnumber put: ( #decimal parse | #heximal parse | #posfloat parse ); + at: #posnumber put: ( #heximal parse | #posfloat parse | #decimal parse ); at: #number put: ( ( '-' parse , #posnumber parse <- [:p | p result negated] ) | ( '+' parse zeroMore , #posnumber parse ) ). g at: #plainChar put: ( PeAny textResult <- [:p | p last] ); @@ -109,8 +112,8 @@ ColaParsingGrammar := [ Grammar new ] g at: #unary put: ( ( #alpha parse , ( #alpha parse | #digit parse ) zeroMore ) textResult, _ ); at: #binary put: ( ( '-+!%&*,/<=>[EMAIL PROTECTED]|~' parseClass oneMore ) textResult , _ ); at: #keyword put: ( ( #alpha parse , ( #alpha parse | #digit parse ) zeroMore , ':' parse ) textResult , _ ). - g at: #unymsg put: ( #unary parse ->0 <- [:p | Array with: [EMAIL PROTECTED] ); - at: #binmsg put: ( #binary parse ->0 , #expr parse ->1 , _ <- [:p | Array with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] ); + g at: #unymsg put: ( #unary parse ->0 <- [:p | OrderedCollection with: [EMAIL PROTECTED] ); + at: #binmsg put: ( #binary parse ->0 , #expr parse ->1 , _ <- [:p | OrderedCollection with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] ); at: #keyarg put: ( #keyword parse ->0 , #expr parse ->1 , _ <- [:p | OrderedCollection with: [EMAIL PROTECTED] with: [EMAIL PROTECTED] ); at: #keymsg put: ( #keyarg parse ->0 , ( #keyword parse ->1 , #expr parse ->2 , _ <- [:p | ([EMAIL PROTECTED]) first: ([EMAIL PROTECTED]) first, ([EMAIL PROTECTED]); add: ([EMAIL PROTECTED]); yourself] ) zeroMore <- [:p | ([EMAIL PROTECTED])] @@ -129,7 +132,7 @@ ColaParsingGrammar := [ Grammar new ] at: #expression put: _ , ( #expr parse | #eof parse | #error parse ). ] -"mutually recursive rules between the above grammars can now be resolve" +"mutually recursive rules between the above grammars can now be resolved" [ ColaParsingGrammar startSymbol: #grammar. diff -r 2e8939abc3c6 function/jolt2/Compiler.st --- a/function/jolt2/Compiler.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/Compiler.st Fri Apr 25 16:12:38 2008 -0600 @@ -919,7 +919,7 @@ Compiler xEvaluate: form Compiler errorUndefined: aSymbol [ self error: 'undefined: ', aSymbol ] Compiler errorSyntax: form [ self error: 'syntax error: ', form printString ] -Compiler errorArgumentCount: form [ self error: 'wrong number of aguments: ', form printString ] +Compiler errorArgumentCount: form [ self error: 'wrong number of arguments: ', form printString ] Compiler errorLoop: form [ self error: 'no loop: ', form printString ] "----------------------------------------------------------------" diff -r 2e8939abc3c6 function/jolt2/Grammar.st --- a/function/jolt2/Grammar.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/Grammar.st Fri Apr 25 16:12:38 2008 -0600 @@ -39,6 +39,11 @@ Grammar startRule: pe startRule := PeRule withValue: pe name: #'<start>'. dirty := true. self finalise. +] + +Grammar extends: aGrammar +[ + aGrammar do: [:assoc | self at: assoc key ifAbsentPut: assoc value]. ] Grammar finalise diff -r 2e8939abc3c6 function/jolt2/Makefile --- a/function/jolt2/Makefile Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/Makefile Fri Apr 25 16:12:38 2008 -0600 @@ -28,7 +28,10 @@ all : main$(OBJEXT) all : main$(OBJEXT) test : main$(OBJEXT) .FORCE - ./main$(OBJEXT) boot.k sanaras.k + ./main$(OBJEXT) -L../jolt-burg boot.k sanaras.k + +test-old: main$(OBJEXT) .FORCE + cd ../examples && $(MAKE) test JOLT="../../jolt2/main$(OBJEXT) -L../../jolt-burg" .SUFFIXES : diff -r 2e8939abc3c6 function/jolt2/Options.st --- a/function/jolt2/Options.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/Options.st Fri Apr 25 16:12:38 2008 -0600 @@ -20,13 +20,15 @@ { import: Objects } -Options : Object ( verbose compile list libdir ) +Options : Object ( verbose compile list libdir progdir ) Options verbose [ ^verbose ] Options compile [ ^compile ] Options list [ ^list ] Options libdir: aString [ libdir := aString ] Options libdir [ ^libdir ] +Options progdir: aDir [ progdir := aDir ] +Options progdir [ ^progdir ] Options new [ diff -r 2e8939abc3c6 function/jolt2/Parser.st --- a/function/jolt2/Parser.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/Parser.st Fri Apr 25 16:12:38 2008 -0600 @@ -113,5 +113,5 @@ Parser errorContents Parser setResultFromFunction_: _function { - self->v_result= ((oop(*)())v__function)(v__closure, self, self, self->v_result); + self->v_result= ((oop(*)())v__function)(v__closure, v_stateful_self, v_self, self->v_result); } diff -r 2e8939abc3c6 function/jolt2/boot.k --- a/function/jolt2/boot.k Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/boot.k Fri Apr 25 16:12:38 2008 -0600 @@ -191,16 +191,53 @@ | error ) } match: node])) -;; methods - -(define add-method ; type selector implementation - (lambda (type selector implementation) - [[type _vtable] methodAt: selector put: implementation with: 0])) - -(syntax define-send ; selector type args... expr - (lambda (form compiler) - (let ((selector [form second]) - (type [form third]) - (args [form copyFrom: '3 to: [[form size] - '2]]) - (expr [form last])) - `(add-method ,type ,selector (lambda (_closure _self self ,@args) ,expr))))) +;; Add features that aren't present in the original grammar. +(define ColaFunctionGrammar (import "ColaFunctionGrammar")) +(define Integer (import "Integer")) +(define new-grammar '{ + // Add character literals ($CHAR) + atom = number | charLiteral | identifier | string | grammar + charLiteral = '$' char->0 <- [self @ '0] + + // Add octal character escapes ("\\([0-3]?[0-7])?[0-7]"). + escapeSeq = '\\' (escapeChar | octalChar | plainChar) + oct = [0-7] + octalChar = (([0-3] oct oct) | (oct oct) | oct) $ <- [Integer fromString: [self result] base: '8] + + // Binary integers. + posnumber = heximal | binimal | posfloat | decimal + binimal = '0b' [0-1]+ $ <- [Integer fromString: [self result] base: '2] + + // Variadic message sends ([obj msg expr...]). + send = '[' _ expr->0 _ message->1 _ (expr->2 _ <- [[self @ '1] add: [self @ '2]])* + ']' <- [Expression with: 'send + with: [Expression with: 'quote with: [[[self @ '1] first] asSymbol]] + with: [self @ '0] + withAll: [self @ '1] from: '1] + ; + EXTENDS: ColaFunctionGrammar // Import from the default grammar. + expression // Start term + }) + +[new-grammar name: 'ColaFunctionGrammar] +(export "ColaFunctionGrammar" new-grammar) + +(load "syntax.k") +(load "debug.k") +(load "object.k") + +(define *package-list* [IdentitySet new]) + +(define %require + (lambda (package) + (or [*package-list* includes: [package asSymbol]] + (let () + (load [[[package asString] , '".k"] _stringValue]) + [*package-list* add: [package asSymbol]])))) + +(syntax require + (lambda (node comp) + (let ((requires [WriteStream on: [Expression new: '8]])) + (for (i '1 2 [[node size] - '1]) + [requires nextPut: `(%require ,[node at: i])]) + `(let () ,@[requires contents])))) diff -r 2e8939abc3c6 function/jolt2/main.st --- a/function/jolt2/main.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/jolt2/main.st Fri Apr 25 16:12:38 2008 -0600 @@ -91,7 +91,10 @@ ColaEvaluator map: aBlock ColaEvaluator readFileNamed: fileName [ - self readFile: (fileName = '-' ifTrue: [StdIn] ifFalse: [File open: fileName]) + self readFile: (fileName = '-' ifTrue: [StdIn] + ifFalse: [((File openIfPresent: fileName) + ifNil: [File openIfPresent: Options progdir, '/', fileName]) + ifNil: [File open: Options libdir, '/', fileName]]) ] ColaEvaluator readFile: aFile @@ -108,9 +111,14 @@ ColaEvaluator readFile: aFile [ - | done | + | done args arg | "ColaFunctionGrammar println." + Options progdir: (OS argumentAt: 0) dirname. Options libdir: '.'. - OS arguments do: [:arg | (Options parseOption: arg) ifFalse: [ColaEvaluator readFileNamed: (done := arg)]]. + args := OS arguments. + [args notEmpty] + whileTrue: + [ arg := args removeFirst. + (Options parseOption: arg) ifFalse: [ColaEvaluator readFileNamed: (done := arg)]]. done ifFalse: [ColaEvaluator readFile: StdIn]. ] diff -r 2e8939abc3c6 function/objects/SequenceableCollection.st --- a/function/objects/SequenceableCollection.st Wed Apr 23 23:45:22 2008 -0600 +++ b/function/objects/SequenceableCollection.st Fri Apr 25 16:12:38 2008 -0600 @@ -216,6 +216,12 @@ SequenceableCollection inject: result in SequenceableCollection inject: result into: binaryBlock [ self do: [:element | result := binaryBlock value: result value: element]. + ^result +] + +SequenceableCollection reverseInject: result into: binaryBlock +[ + self reverseDo: [:element | result := binaryBlock value: result value: element]. ^result ]
Generate assembler from Jolt code. diff -r 1e71558180f0 function/examples2/slink/README --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/function/examples2/slink/README Fri Apr 25 16:12:05 2008 -0600 @@ -0,0 +1,75 @@ +SLINK 0.3 +********* + +Slink is the beginning of a statically-linking compiler extension for +Jolt2 (think "Static LINK" or "System LINK"). It was partly inspired +by John Leuner's Common Lisp port of jolt-burg that creates +relocatable ELF objects. I'm basically attempting to land the same +kinds of features in COLA proper without changing too much of the +existing compiler machinery. + +It has many limitations, but is a proof-of-concept and will probably +evolve (the main direction for evolution is to make the changes less +and less dependent on patching Jolt2's Id sources directly, and +instead accomplish its features at runtime via slink.k and friends). + +The centerpiece of this system is slink-compile, which currently can +only generate i386 assembly code. The following new syntax is +introduced: + +(define (slink SYMBOL)) + Import SYMBOL from the system linker. If running with the dynamic + compiler, this is equivalent to: + + (active SYMBOL (dlsym "SYMBOL")) + + If under the static compiler (slink-compile), this will cause future + references to SYMBOL to be resolved at link time rather than + runtime. + +(define (slink SYMBOL) EXPRESSION) + Create a region of memory containing the results of EXPRESSION. + SYMBOL is exported to the system linker. Only expressions resulting + in integers, strings, floats, and lambdas currently work. + +To get a feel for things, run "make test" which exercises slink both +at runtime and compile time. You'll notice that the results of this +execution are a binary executable (slinktest) with no runtime +dependency on COLA. + +IMPLEMENTATION +************** + +I did a lot of work creating a bunch of slink-specific methods in the +existing COLA compiler. Now I'm gradually undoing as much of that +work as possible to leave only the core features in Jolt2, so that the +rest can be just another unprivileged application. + +Once you understand what the slink syntax does, it shouldn't be too +hard to follow what I needed to do to get things working. A "grep -i +slink *.st" is very informative (and half the reason I needed to find +a catchy name that wouldn't be buried in the other identifiers). + +Toplevel Jolt expressions are gathered up and attached to the system's +initialisation functions so that they are executed at program start +(for i386, using the same method as C++ constructors). + +I'm in the process of creating a "compiler-stage" syntax which +immediately evaluates its child expressions in the compiler instead of +compiling them. Marking up boot.k will make it possible to be used +for slink-compile as well. + +It would be really nice to implement a few more CodeGenerator backends +to bypass assembly language entirely and generate binaries. + +Slink has a naive three-region model for assembler output. First +comes a bss section with all the variables, then a data section with +all the strings, then finally a text section with all the compiled +functions. To my knowledge, this is adequate for the platforms on +which COLA already runs, but of course it would be good to be able to +provide something akin to linker scripts in the future to allow much +more flexible layout. + +Have fun, + +Michael FIG <[EMAIL PROTECTED]>, 2008-04-17 diff -r 1e71558180f0 function/examples2/slink/main.k --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/function/examples2/slink/main.k Fri Apr 25 16:12:05 2008 -0600 @@ -0,0 +1,37 @@ +(syntax syntax-test + (lambda (node compiler) + (printf "Here's a little test of compile-time syntax.\n") + '(printf "Here's a little test of runtime syntax.\n"))) + +;; FIXME: Eventually slink-compile should include this for us. +(syntax addrof ; (addrof varName) => address of varName + (lambda (node compiler) + (or (and [[node size] = '2] + [[node second] isSymbol]) + [compiler errorSyntax: node]) + [[compiler lookupVariable: [node second]] translateLvalue: compiler])) + +(define (slink printf)) +(printf "Hello from constructor\n") +(define zot 0x123456) +;;(slink mylist '(1 2 3 "foo" 0.3456)) +(define baz zot) +(define (slink zot_addr) zot) + +(define (slink hello) + (lambda (progname argc) + (printf "Have an int: 0x%x@(0x%x==0x%x), and a copy [EMAIL PROTECTED]" + zot (addrof zot) zot_addr baz (addrof baz)) + (syntax-test) + (printf "Goodbye, world (%s with %d arguments)!\n" progname argc))) + +(define test2 + (lambda () + (printf "Another test from constructor\n"))) + +(define (slink main) + (lambda (argc argv) + (hello (long@ argv) (- argc 1)) + 0)) + +(test2) diff -r 1e71558180f0 function/examples2/slink/slink.k --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/function/examples2/slink/slink.k Fri Apr 25 16:12:05 2008 -0600 @@ -0,0 +1,63 @@ +(define slink-require + (lambda (filename compiler generator environment package-list) + (let ((path filename) + (file [File openIfPresent: filename])) + (or file + (let () + (set path [[[Options libdir] , '"/"] , filename]) + (set file [File openIfPresent: path]))) + (or file + (let () + (set path [[[Options progdir] , '"/"] , filename]) + (set file [File openIfPresent: path]))) + (if file + (let ((parser [ColaFunctionGrammar parserOn: file]) + (expr 0)) + [StdOut nextPutAll: '"; compiling: "] [StdOut nextPutAll: path] [StdOut cr] + (while (set expr [parser next]) + (or (and [[expr size] = '2] + [[expr first] = 'require] + [[expr second] isArray] + (let ((qpackage [expr second])) + (and [[qpackage size] = '2] + [[qpackage first] = 'quote] + [[qpackage second] isSymbol] + (let ((package [qpackage second])) + (or [package-list includes: package] + (let ((filename [[package asString] , '".k"])) + ;; Allow code to require other packages with (require 'package). + (slink-require filename compiler generator environment package-list) + [package-list add: package])))))) + [compiler compile: expr for: generator with: environment]))) + (let () + [StdErr nextPutAll: '";; cannot open "] + [StdErr nextPutAll: filename] + [StdErr cr]))))) + + +(define slink-compile + (lambda (path) + (let ((pathstr [String value_: path]) + (outname [pathstr , '".s"]) + (CodeGenerator (import "CodeGenerator")) + (gen [[CodeGenerator default] static]) + (SlinkEnvironment (import "SlinkEnvironment")) + (env [SlinkEnvironment new]) + (Compiler (import "Compiler")) + (CompilerOptions (import "CompilerOptions")) + (package-list [IdentitySet new])) + + [StdErr nextPutAll: '";; slink-compile "] [StdErr nextPutAll: pathstr] + [StdErr nextPutAll: '" starting"] [StdErr cr] + + ;; [CompilerOptions verboseTree: '1] + ;(slink-require '"sboot.k" Compiler gen env package-list) + (slink-require pathstr Compiler gen env package-list) + ;; [CompilerOptions verboseTree: 0] + + (let ((out [File create: outname])) + [StdOut nextPutAll: '"; write output to "] [StdOut nextPutAll: outname] [StdOut cr] + [gen toStream: out] + [out close]) + [StdErr nextPutAll: '";; slink-compile "] [StdErr nextPutAll: pathstr] + [StdErr nextPutAll: '" finished"] [StdErr cr]))) diff -r 1e71558180f0 function/examples2/slink/test.k --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/function/examples2/slink/test.k Fri Apr 25 16:12:05 2008 -0600 @@ -0,0 +1,9 @@ +((define (slink hello) (lambda (msg) (printf "hello %s\n" msg))) "the first time") +(define zot hello) +(define (slink zorgar) (let () 42)) +(printf "these should match %x == %x but this %d == 42!\n" hello zot zorgar) +(hello "the second time") +(zot "the third time") + +(load "main.k") +(hello "from test.k" 666) diff -r 1e71558180f0 function/jolt2/CodeGenerator-arm.st --- a/function/jolt2/CodeGenerator-arm.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/CodeGenerator-arm.st Fri Apr 25 16:12:05 2008 -0600 @@ -29,9 +29,9 @@ ARMCodeGenerator : CodeGenerator ( tempsSize registerList r0 r1 ip sp lr pc ) -ARMCodeGenerator new -[ - self := super new. +ARMCodeGenerator newScope +[ + self := super newScope. tempsSize := 0. ccrs add: (r0 := Register withClass: I4 name: 'r0' encoding: 0); diff -r 1e71558180f0 function/jolt2/CodeGenerator-i386.st --- a/function/jolt2/CodeGenerator-i386.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/CodeGenerator-i386.st Fri Apr 25 16:12:05 2008 -0600 @@ -29,9 +29,9 @@ Intel32CodeGenerator : CodeGenerator ( tempsSize eax ecx edx ebx esp ebp esi edi cx cl ) -Intel32CodeGenerator new -[ - self := super new. +Intel32CodeGenerator newScope +[ + self := super newScope. tempsSize := 0. ccrs add: (eax := Register withClass: I4 name: '%eax' encoding: 0x40); @@ -153,62 +153,123 @@ Intel32CodeGenerator emit: call argument "----------------------------------------------------------------" -StaticIntel32CodeGenerator : Intel32CodeGenerator () - -StaticIntel32CodeGenerator addrgp4 :d :v [ StdOut nextPutAll: ' movl '; nextPut: $$; print: v; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator addrjp4 :d :l [ StdOut nextPutAll: ' movl $L'; print: l ordinal; nextPut: $,; print: d; cr ] - -StaticIntel32CodeGenerator addlI: i R: d [ StdOut nextPutAll: ' addl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator addlI_: i R: d [ StdOut nextPutAll: ' addl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator addlR: s R: d [ StdOut nextPutAll: ' addl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator andlR: s R: d [ StdOut nextPutAll: ' andl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator callMb: b [ StdOut nextPutAll: ' call ('; print: b; nextPutAll: ')\n' ] -StaticIntel32CodeGenerator cltd [ StdOut nextPutAll: ' cltd\n' ] -StaticIntel32CodeGenerator cmplI: i R: d [ StdOut nextPutAll: ' cmpl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator cmplI_: i Md: d b: b [ StdOut nextPutAll: ' cmpl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr] -StaticIntel32CodeGenerator cmplR: s R: d [ StdOut nextPutAll: ' cmpl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator define: l [ StdOut nextPutAll: 'L'; print: l ordinal; nextPut: $:; cr ] -StaticIntel32CodeGenerator idivlR: s [ StdOut nextPutAll: ' idivl '; print: s; cr ] -StaticIntel32CodeGenerator imullR: s R: d [ StdOut nextPutAll: ' imull '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator jeL: l [ StdOut nextPutAll: ' je L'; print: l ordinal; cr ] -StaticIntel32CodeGenerator jgeL: l [ StdOut nextPutAll: ' jge L'; print: l ordinal; cr ] -StaticIntel32CodeGenerator jmpL: l [ StdOut nextPutAll: ' jmp L'; print: l ordinal; cr ] -StaticIntel32CodeGenerator jmpMb: b [ StdOut nextPutAll: ' jmp *'; print: b; cr ] -StaticIntel32CodeGenerator jneL: l [ StdOut nextPutAll: ' jne L'; print: l ordinal; cr ] -StaticIntel32CodeGenerator lealMd: d b: b R: r [ StdOut nextPutAll: ' leal '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] -StaticIntel32CodeGenerator lealMd_: d b: b R: r [ StdOut nextPutAll: ' leal '; print: (SmallInteger value_: d); nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] -StaticIntel32CodeGenerator movbR: r Mb: b [ StdOut nextPutAll: ' movb '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] -StaticIntel32CodeGenerator movlI_: i R: d [ StdOut nextPutAll: ' movl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator movlMb: b R: r [ StdOut nextPutAll: ' movl ('; print: b; nextPutAll: '),'; print: r; cr] -StaticIntel32CodeGenerator movlMd: d b: b R: r [ StdOut nextPutAll: ' movl '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] -StaticIntel32CodeGenerator movlMd_: d R: r [ StdOut nextPutAll: ' movl '; print: (SmallInteger value_: d); nextPut: $,; print: r; cr ] -StaticIntel32CodeGenerator movlR: r Mb: b [ StdOut nextPutAll: ' movl '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] -StaticIntel32CodeGenerator movlR: s Md: d b: b [ StdOut nextPutAll: ' movl '; print: s; nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr] -StaticIntel32CodeGenerator movlR: s R: d [ s == d ifFalse: [StdOut nextPutAll: ' movl '; print: s; nextPut: $,; print: d; cr] ] -StaticIntel32CodeGenerator movsblMb: s R: d [ StdOut nextPutAll: ' movsbl ('; print: s; nextPutAll: '),'; print: d; cr ] -StaticIntel32CodeGenerator movswlMb: s R: d [ StdOut nextPutAll: ' movswl ('; print: s; nextPutAll: '),'; print: d; cr ] -StaticIntel32CodeGenerator movwR: r Mb: b [ StdOut nextPutAll: ' movw '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] -StaticIntel32CodeGenerator neglR: d [ StdOut nextPutAll: ' negl '; print: d; cr ] -StaticIntel32CodeGenerator notlR: d [ StdOut nextPutAll: ' notl '; print: d; cr ] -StaticIntel32CodeGenerator orlR: s R: d [ StdOut nextPutAll: ' orl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator poplR: d [ StdOut nextPutAll: ' popl '; print: d; cr ] -StaticIntel32CodeGenerator pushlR: s [ StdOut nextPutAll: ' pushl '; print: s; cr ] -StaticIntel32CodeGenerator ret [ StdOut nextPutAll: ' ret\n' ] -StaticIntel32CodeGenerator sallR: s R: d [ StdOut nextPutAll: ' sall '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator sarlR: s R: d [ StdOut nextPutAll: ' sarl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator seteR: d [ StdOut nextPutAll: ' sete '; print: d; cr ] -StaticIntel32CodeGenerator setgR: d [ StdOut nextPutAll: ' setg '; print: d; cr ] -StaticIntel32CodeGenerator setgeR: d [ StdOut nextPutAll: ' setge '; print: d; cr ] -StaticIntel32CodeGenerator setlR: d [ StdOut nextPutAll: ' setl '; print: d; cr ] -StaticIntel32CodeGenerator setleR: d [ StdOut nextPutAll: ' setle '; print: d; cr ] -StaticIntel32CodeGenerator setneR: d [ StdOut nextPutAll: ' setne '; print: d; cr ] -StaticIntel32CodeGenerator shllR: s R: d [ StdOut nextPutAll: ' shll '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator shrlR: s R: d [ StdOut nextPutAll: ' shrl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator sublI: i R: d [ StdOut nextPutAll: ' subl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator sublI_: i R: d [ StdOut nextPutAll: ' subl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator sublR: s R: d [ StdOut nextPutAll: ' subl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator testlR: s R: d [ StdOut nextPutAll: ' testl '; print: s; nextPut: $,; print: d; cr ] -StaticIntel32CodeGenerator xorlR: s R: d [ StdOut nextPutAll: ' xorl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator : Intel32CodeGenerator (bss data text ctor lambdas extern) +StaticIntel32CodeGenerator new +[ + self := super new. + bss := IdentitySet new. + data := WriteStream on: (String new: 8192). + ctor := WriteStream on: (String new: 8192). + lambdas := WriteStream on: (String new: 8192). + text := ctor. +] + +StaticIntel32CodeGenerator newScope +[ + | newGen saveBss saveData saveCtor saveLambdas saveText | + saveBss := bss. + saveData := data. + saveCtor := ctor. + saveLambdas := lambdas. + saveText := text. + self := super newScope. + bss := saveBss. + data := saveData. + ctor := saveCtor. + lambdas := saveLambdas. + text := saveText. +] + +StaticIntel32CodeGenerator toStream: out +[ + | hdr dataPfx ctorPtr label textPfx ctorPfx ctorSfx | + hdr := '# Generated by COLA ', self versionString, '\n'. + + dataPfx := data position == 0 ifTrue: [''] ifFalse: ['\t.data\n']. + textPfx := (ctor position + lambdas position) == 0 ifTrue: [''] ifFalse: ['\n\t.text\n']. + + ctor position == 0 + ifTrue: [ctorPtr := ''. ctorPfx := ''. ctorSfx := ''] + ifFalse: [ label := 'L', Label new ordinal asString. + ctorPtr := '\n\t.section .ctors\n\t.long ', label, '\n'. + ctorPfx := label, ':\n'. + ctorSfx := '\tret\n']. + + out nextPutAll: hdr. + bss do: [:elt | out nextPutAll: '\t.lcomm '; nextPutAll: (self slinkName: elt asString); nextPutAll: ', 4'; cr]. + + out nextPutAll: dataPfx. + out nextPutAll: (String size: data position value_: data collection _stringValue). + + out nextPutAll: ctorPtr. + + out nextPutAll: textPfx. + + out nextPutAll: ctorPfx. + out nextPutAll: (String size: ctor position value_: ctor collection _stringValue). + out nextPutAll: ctorSfx. + + out nextPutAll: (String size: lambdas position value_: lambdas collection _stringValue). +] + +StaticIntel32CodeGenerator define: l +[ + text == ctor ifFalse: [text nextPutAll: 'L'; print: l ordinal; nextPut: $:; cr] +] + +StaticIntel32CodeGenerator addrgp4 :d :v [ text nextPutAll: ' movl $'; print: v; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator addlI: i R: d [ text nextPutAll: ' addl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator addlI_: i R: d [ text nextPutAll: ' addl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator addlR: s R: d [ text nextPutAll: ' addl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator andlR: s R: d [ text nextPutAll: ' andl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator callMb: b [ text nextPutAll: ' call *'; print: b; cr ] +StaticIntel32CodeGenerator cltd [ text nextPutAll: ' cltd'; cr ] +StaticIntel32CodeGenerator cmplI: i R: d [ text nextPutAll: ' cmpl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator cmplI_: i Md: d b: b [ text nextPutAll: ' cmpl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr] +StaticIntel32CodeGenerator cmplR: s R: d [ text nextPutAll: ' cmpl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator idivlR: s [ text nextPutAll: ' idivl '; print: s; cr ] +StaticIntel32CodeGenerator imullR: s R: d [ text nextPutAll: ' imull '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator jeL: l [ text nextPutAll: ' je L'; print: l ordinal; cr ] +StaticIntel32CodeGenerator jgeL: l [ text nextPutAll: ' jge L'; print: l ordinal; cr ] +StaticIntel32CodeGenerator jmpL: l [ text nextPutAll: ' jmp L'; print: l ordinal; cr ] +StaticIntel32CodeGenerator jmpMb: b [ text nextPutAll: ' jmp *'; print: b; cr ] +StaticIntel32CodeGenerator jneL: l [ text nextPutAll: ' jne L'; print: l ordinal; cr ] +StaticIntel32CodeGenerator lealMd: d b: b R: r [ text nextPutAll: ' leal '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] +StaticIntel32CodeGenerator lealMd_: d b: b R: r [ text nextPutAll: ' leal '; print: (SmallInteger value_: d); nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] +StaticIntel32CodeGenerator lealS: s R: r [ text nextPutAll: ' leal '; nextPutAll: s; nextPut: $,; print: r; cr] +StaticIntel32CodeGenerator movbR: r Mb: b [ text nextPutAll: ' movb '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] +StaticIntel32CodeGenerator movlI_: i R: d [ text nextPutAll: ' movl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator movlMb: b R: r [ text nextPutAll: ' movl ('; print: b; nextPutAll: '),'; print: r; cr] +StaticIntel32CodeGenerator movlMd: d b: b R: r [ text nextPutAll: ' movl '; print: d; nextPut: $(; print: b; nextPutAll: '),'; print: r; cr] +StaticIntel32CodeGenerator movlMd_: d R: r [ text nextPutAll: ' movl '; print: (SmallInteger value_: d); nextPut: $,; print: r; cr ] +StaticIntel32CodeGenerator movlR: r Mb: b [ text nextPutAll: ' movl '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] +StaticIntel32CodeGenerator movlR: s Md: d b: b [ text nextPutAll: ' movl '; print: s; nextPut: $,; print: d; nextPut: $(; print: b; nextPut: $); cr] +StaticIntel32CodeGenerator movlR: s R: d [ s == d ifFalse: [text nextPutAll: ' movl '; print: s; nextPut: $,; print: d; cr] ] +StaticIntel32CodeGenerator movlS: s R: d [ text nextPutAll: ' movl '; nextPutAll: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator movsblMb: s R: d [ text nextPutAll: ' movsbl ('; print: s; nextPutAll: '),'; print: d; cr ] +StaticIntel32CodeGenerator movswlMb: s R: d [ text nextPutAll: ' movswl ('; print: s; nextPutAll: '),'; print: d; cr ] +StaticIntel32CodeGenerator movwR: r Mb: b [ text nextPutAll: ' movw '; print: r; nextPutAll: ',('; print: b; nextPut: $); cr ] +StaticIntel32CodeGenerator neglR: d [ text nextPutAll: ' negl '; print: d; cr ] +StaticIntel32CodeGenerator notlR: d [ text nextPutAll: ' notl '; print: d; cr ] +StaticIntel32CodeGenerator orlR: s R: d [ text nextPutAll: ' orl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator poplR: d [ text nextPutAll: ' popl '; print: d; cr ] +StaticIntel32CodeGenerator pushlR: s [ text nextPutAll: ' pushl '; print: s; cr ] +StaticIntel32CodeGenerator ret [ text == ctor ifFalse: [text nextPutAll: ' ret'; cr] ] +StaticIntel32CodeGenerator sallR: s R: d [ text nextPutAll: ' sall '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator sarlR: s R: d [ text nextPutAll: ' sarl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator seteR: d [ text nextPutAll: ' sete '; print: d; cr ] +StaticIntel32CodeGenerator setgR: d [ text nextPutAll: ' setg '; print: d; cr ] +StaticIntel32CodeGenerator setgeR: d [ text nextPutAll: ' setge '; print: d; cr ] +StaticIntel32CodeGenerator setlR: d [ text nextPutAll: ' setl '; print: d; cr ] +StaticIntel32CodeGenerator setleR: d [ text nextPutAll: ' setle '; print: d; cr ] +StaticIntel32CodeGenerator setneR: d [ text nextPutAll: ' setne '; print: d; cr ] +StaticIntel32CodeGenerator shllR: s R: d [ text nextPutAll: ' shll '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator shrlR: s R: d [ text nextPutAll: ' shrl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator sublI: i R: d [ text nextPutAll: ' subl '; nextPut: $$; print: i; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator sublI_: i R: d [ text nextPutAll: ' subl '; nextPut: $$; print: (SmallInteger value_: i); nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator sublR: s R: d [ text nextPutAll: ' subl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator testlR: s R: d [ text nextPutAll: ' testl '; print: s; nextPut: $,; print: d; cr ] +StaticIntel32CodeGenerator xorlR: s R: d [ text nextPutAll: ' xorl '; print: s; nextPut: $,; print: d; cr ] Intel32CodeGenerator spilli4: reg to: tmp [ self movlR: reg Md: tmp offset b: esp ] Intel32CodeGenerator reloadi4: reg from: tmp [ self movlMd: tmp offset b: esp R: reg ] @@ -299,7 +360,7 @@ CodeGenerator versionString [ ^self defa CodeGenerator default [ ^Intel32CodeGenerator ] -Intel32CodeGenerator static [ ^StaticIntel32CodeGenerator ] +Intel32CodeGenerator static [ ^StaticIntel32CodeGenerator new ] Intel32CodeGenerator dynamic [ ^DynamicIntel32CodeGenerator ] Intel32CodeGenerator versionString @@ -315,15 +376,83 @@ CodeGenerator isDynamic [ ^false ] CodeGenerator isDynamic [ ^false ] DynamicIntel32CodeGenerator isDynamic [ ^true ] -StaticIntel32CodeGenerator defineVariable: name -[ - StdOut nextPutAll: ' .data\n'. - StdOut nextPutAll: name; nextPutAll: ': .long _'; nextPutAll: name; cr. - StdOut nextPutAll: ' .text\n'. -] - -DynamicIntel32CodeGenerator defineVariable: name -[ +NameManglingTable : Array () +[ + "For (relative) readability: + _a-zA-Z0-9 -> _a-zA-Z0-9 + . -> _<hex-value>_" + NameManglingTable := Array new: 256. + NameManglingTable atAllPut: #'mangleOther:to:'. + '_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' + do: [:char | NameManglingTable at: char put: #'mangleLetter:to:']. +] + +Intel32CodeGenerator slinkName: name +[ + | uscore mangled | + { +#if defined(__MACH__) || defined(__CYGWIN__) || defined(__WIN32__) + v_uscore = 1; +#endif + }. + mangled := (String new: name size * 2) writeStream. + uscore ifTrue: [mangled nextPut: $_]. + name do: [:char | self perform: (NameManglingTable at: char) with: char with: mangled]. + ^mangled contents +] + +Intel32CodeGenerator mangleLetter: aCharacter to: aStream [ aStream nextPut: aCharacter ] +Intel32CodeGenerator mangleOther: aCharacter to: aStream +[ + aStream nextPut: $_; print: aCharacter base: 16; nextPut: $_. +] + +StaticIntel32CodeGenerator slinkVariable: name [ bss add: name ] +StaticIntel32CodeGenerator slinkImport: name [] +StaticIntel32CodeGenerator slinkExport: name translate: aForm with: aCompiler +[ + | ext result | + extern := self slinkName: name. + result := aForm translate: aCompiler. + (extern and: [result name == #slink or: [result name == #slinki]]) + ifTrue: [data nextPutAll: '\n\t.globl '; nextPutAll: extern; cr; + nextPutAll: '\t.set '; nextPutAll: extern; nextPut: $,; nextPutAll: result arg; cr. + extern := nil]. + ^nil +] + +StaticIntel32CodeGenerator compileLambda: form with: aCompiler +[ + | save label | + save := text. + text == ctor ifTrue: [text := lambdas]. + extern ifTrue: [ text cr; nextPutAll: '\t.globl '; nextPutAll: extern; cr; + nextPutAll: extern; nextPut: $:; cr. + extern := nil ]. + label := aCompiler compileLambda: form. + text := save. + ^SLINK new arg: ('L', label ordinal asString) +] + +StaticIntel32CodeGenerator translateData_: _bytes length: aLength +[ + | name comma s | + extern + ifTrue: [ name := extern. + data cr; nextPutAll: '\t.globl '; nextPutAll: name; cr. + extern := nil ] + ifFalse: [ name := 'L', (Label new ordinal asString) ]. + + s := String size: aLength value_: _bytes. + data nextPutAll: name; nextPut: $:. + 0 to: aLength - 1 do: + [:i | i \\ 8 == 0 ifTrue: [data cr; nextPutAll: '\t.byte '. comma := '']. + data nextPutAll: comma; nextPutAll: '0x'; print_x: (s at: i) _integerValue. + comma := ', ' + ]. + data cr. + + ^SLINK new arg: name ] "----------------------------------------------------------------" @@ -353,6 +482,8 @@ Intel32Grammar := [ at: #VOID add: #(label ) do: [:op :gen | gen define: op ]; at: #REG add: #(cnsti4 ) do: [:op :gen | gen movlI_: op arg R: op output ]; at: #REG add: #(cnstp4 ) do: [:op :gen | gen movlI_: op arg R: op output ]; + at: #REG add: #(slink ) do: [:op :gen | gen lealS: (gen slinkName: op arg) R: op output ]; + at: #REG add: #(slinki ) do: [:op :gen | gen movlS: (gen slinkName: op arg) R: op output ]; at: #REG add: #(parami4 ) do: [:op :gen | ]; at: #REG add: #(addrfp4 ) do: [:op :gen | gen movlR: gen ebp R: op output ]; at: #REG add: #(addrgp4 ) do: [:op :gen | gen movlI_: op arg _address R: op output ]; @@ -367,7 +498,7 @@ Intel32Grammar := [ movlR: gen ecx R: op output ]; at: #REG add: #(comi4 REG ) do: [:op :gen | gen notlR: op output ]; at: #REG add: #(negi4 REG ) do: [:op :gen | gen neglR: op output ]; - at: #REG add: #(calli4 REG ) do: [:op :gen | gen calli4: op ]; + at: #REG add: #(calli4 REG ) do: [:op :gen | gen calli4: op]; at: #REG add: #(asgni1 REG REG) do: [:op :gen | gen movlR: op lhs output R: gen ecx; movbR: gen cl Mb: op rhs output ]; at: #REG add: #(asgni2 REG REG) do: [:op :gen | gen movlR: op lhs output R: gen ecx; @@ -452,7 +583,7 @@ StaticIntel32CodeGenerator generate: tre StaticIntel32CodeGenerator generate: tree [ self finaliseFrame. - tree printOn: StdOut indent: 0. StdOut cr. + "tree printOn: StdOut indent: 0. StdOut cr." tree generate: self. ^Array with: 0 with: 0. ] diff -r 1e71558180f0 function/jolt2/CodeGenerator-ppc.st --- a/function/jolt2/CodeGenerator-ppc.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/CodeGenerator-ppc.st Fri Apr 25 16:12:05 2008 -0600 @@ -39,9 +39,9 @@ PowerPCRegister location [ ^location ] PowerPCCodeGenerator : CodeGenerator ( r0 r1 r2 r3 r11 r12 ) -PowerPCCodeGenerator new -[ - self := super new. +PowerPCCodeGenerator newScope +[ + self := super newScope. r0 := PowerPCRegister withClass: I4 name: 'r0' encoding: 0. r1 := PowerPCRegister withClass: I4 name: 'r1' encoding: 1. r2 := PowerPCRegister withClass: I4 name: 'r2' encoding: 2. diff -r 1e71558180f0 function/jolt2/CodeGenerator.st --- a/function/jolt2/CodeGenerator.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/CodeGenerator.st Fri Apr 25 16:12:05 2008 -0600 @@ -28,11 +28,16 @@ CodeGenerator : Object ( ccrs csrs spill CodeGenerator withLabels: labelCollection [ - self := self new. + self := self newScope. labels := labelCollection. ] CodeGenerator new +[ + self := self newScope +] + +CodeGenerator newScope [ self := super new. ccrs := RegisterSet new. @@ -111,6 +116,36 @@ CodeGenerator relocateLabels_: _addr labels do: [:label | label relocate_: _addr] ] +CodeGenerator slinkVariable: name [] +CodeGenerator slinkImport: name [^name _dlsym] +CodeGenerator slinkExport: name translate: aForm with: aCompiler +[ + | entry value | + aForm isSymbol ifTrue: [aForm := Expression with: #addrof with: aForm]. + entry := aCompiler compile: aForm. + value := entry call. + entry free. + ^value +] + +CodeGenerator compileLambda: form with: aCompiler +[ + ^ADDRJP4 new arg: (aCompiler compileLambda: form) +] + +CodeGenerator translateData_: _bytes length: aLength +[ + | _mem | + { + size_t size= ((long)v_aLength) >> 1; + char *mem= malloc(size + 1); + memcpy(mem, v__bytes, size); + mem[size]= '\0'; + v__mem= (oop)mem; + }. + ^CNSTP4 new arg: _mem +] + CodeGenerator enter :e [ self emitPrologue ] CodeGenerator parami4 :s [] CodeGenerator drop :s [] diff -r 1e71558180f0 function/jolt2/Compiler.st --- a/function/jolt2/Compiler.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/Compiler.st Fri Apr 25 16:12:05 2008 -0600 @@ -37,6 +37,7 @@ Variable withName: nameSymbol ] Variable translateRvalue: compiler [ ^INDIRI4 new lhs: (self translateLvalue: compiler) ] +Variable name [ ^name ] GlobalVariable : Variable ( _storage ) @@ -61,6 +62,30 @@ GlobalVariable translateLvalue: compiler GlobalVariable printOn: aStream [ aStream print: name; nextPut: $=; print_x: _storage ] + +SlinkConstant : Variable () + +SlinkConstant translateLvalue: compiler +[ + compiler error: 'cannot write: ', name. +] +SlinkConstant translateRvalue: compiler +[ + ^SLINK new arg: name asString +] + +SlinkVariable : Variable () + +SlinkVariable translateLvalue: compiler +[ + ^SLINK new arg: name asString +] +SlinkVariable translateRvalue: compiler +[ + ^SLINKI new arg: name asString +] + +SlinkVariable printOn: aStream [ aStream print: name ] LocalVariable : Variable ( location ) @@ -115,6 +140,8 @@ Environment : SlotDictionary ( syntax ac Environment new [ ^super basicNew ] +Environment isGlobal [ ^false ] + Environment lookupVariable: name [ ^(active ifTrue: [active at: name ifAbsent: []]) ifNil: [self at: name ifAbsent: []] ] Environment lookupSyntax: name [ ^ syntax ifTrue: [syntax at: name ifAbsent: []] ] @@ -132,9 +159,16 @@ Environment defineActive: name GlobalEnvironment : Environment () +GlobalEnvironment isGlobal [ ^true ] GlobalEnvironment defineVariable: name [ ^self at: name put: (GlobalVariable withName: name) ] GlobalEnvironment defineVariable: name value_: _value [ ^self at: name put: (GlobalVariable withName: name value_: _value) ] - +GlobalEnvironment defineSlink: name value_: _value [ ^self defineVariable: name value_: _value ] + +SlinkEnvironment : Environment () + +SlinkEnvironment isGlobal [ ^true ] +SlinkEnvironment defineVariable: name [ ^self at: name put: (SlinkVariable withName: name) ] +SlinkEnvironment defineSlink: name value_: _value [ ^self at: name put: (SlinkConstant withName: name) ] LocalEnvironment : Environment ( parent ) @@ -151,6 +185,7 @@ LocalEnvironment lookupSyntax: name [ ^( LocalEnvironment defineVariable: name [ ^self at: name put: (LocalVariable withName: name) ] LocalEnvironment defineParameter: name [ ^self at: name put: (ParameterVariable withName: name) ] +LocalEnvironment defineSlink: name value_: _value [ ^parent defineSlink: name value_: _value ] TheGlobalEnvironment := [ GlobalEnvironment new ] @@ -171,10 +206,10 @@ Symbol _dlsym_: _string { _return (oop)_ Compiler : Object ( environment allLabels generatorType breaks continues postProcessors labels ) -Compiler withGeneratorType: genType +Compiler withGeneratorType: genType withEnvironment: theEnv [ self := super new. - environment := TheGlobalEnvironment. + environment := theEnv. allLabels := OrderedCollection new. generatorType := genType. breaks := OrderedCollection new. @@ -204,6 +239,7 @@ Compiler lookupVariable: name Compiler defineActive: name [ ^environment defineActive: name ] Compiler defineVariable: name [ ^environment defineVariable: name ] +Compiler defineSlink: name value_: _value [ ^environment defineSlink: name value_: _value ] Compiler defineParameter: name [ ^environment defineParameter: name ] Compiler defineSyntax: name [ ^environment defineSyntax: name ] @@ -262,7 +298,7 @@ SyntaxTable := [ at: #return put: #xReturn:; at: #label put: #xLabel:; at: #goto put: #xGoto:; - at: #extern put: #xExtern:; + at: #'define-slink' put: #xDefineSlink:; yourself ] @@ -282,12 +318,12 @@ Compiler translateInteger: anInteger Compiler translateFloat: aFloat [ - ^CNSTP4 new arg: aFloat + ^generatorType translateData_: aFloat length: (SmallInteger value_: aFloat _sizeof) ] Compiler translateString: aString [ - ^CNSTP4 new arg: aString _strdup + ^generatorType translateData_: aString _stringValue length: aString size + 1 ] Compiler translateSymbol: aSymbol @@ -628,7 +664,7 @@ Compiler xQuote: expr Compiler xQuote: expr [ | literal | - expr size == 2 ifFalse: [self errorAgumentCount: expr]. + expr size == 2 ifFalse: [self errorArgumentCount: expr]. literal := expr second. (literal isSmallInteger or: [literal isNil]) ifFalse: [CompilerLiterals addLast: literal]. ^CNSTP4 new arg: literal @@ -671,7 +707,7 @@ Compiler defineVariable: name from: form [ | var value | (form size <= 3) ifFalse: [self errorSyntax: form]. - var := self lookupVariable: name ifAbsent: [self defineVariable: name]. + var := self lookupVariable: name ifAbsent: [generatorType slinkVariable: name. self defineVariable: name]. value := form size == 3 ifTrue: [form third translate: self] ifFalse: [CNSTI4 new arg: nil]. @@ -680,7 +716,7 @@ Compiler defineVariable: name from: form ^ASGNI4 new lhs: value; rhs: (var translateLvalue: self). ] -Compiler defineAccessor: accessor from: expr "(define (foo bar...) baz) -> (set-foo bar... baz)" +Compiler defineAccessor: accessor from: expr "(define (foo bar...) baz) -> (define-foo bar... baz)" [ | setter syntax | (accessor isArray and: [accessor size > 0 and: [accessor first isSymbol]]) ifFalse: [self errorSyntax: accessor]. @@ -830,13 +866,15 @@ Compiler xLet: form Compiler xLambda: form [ - ^ADDRJP4 new arg: (self compileLambda: form) + ^generatorType compileLambda: form with: self ] Compiler compileLambda: form [ - | block entry last gen stats | - self := self withGeneratorType: generatorType. + | block entry last gen stats topEnv | + topEnv := environment. + [ topEnv isGlobal not ] whileTrue: [ topEnv := topEnv parent ]. + self := self withGeneratorType: generatorType withEnvironment: topEnv. (block := Block new) scope: self beginScope; add: (entry := self newLabel); @@ -889,14 +927,16 @@ Compiler xGoto: form ^BRA new destination: label ] -Compiler xExtern: form -[ - | name var | - (form size == 2 and: [(name := form second) isSymbol]) ifFalse: [self errorSyntax: form]. - var := self lookupVariable: name ifAbsent: [self defineVariable: name]. - var value_: name _dlsym. - generatorType defineVariable: name. - ^CNSTP4 new arg: var _value +"(define-slink SYMBOL): Import SYMBOL from the system linker + (define-slink SYMBOL EXPRESSION): Export SYMBOL to the system linker, with value EXPRESSION" +Compiler xDefineSlink: form +[ + | name addr | + (form size <= 3 and: [(name := form second) isSymbol]) ifFalse: [self errorSyntax: form]. + form size == 2 + ifTrue: [ addr := generatorType slinkImport: name ] + ifFalse: [ addr := generatorType slinkExport: name translate: form third with: self ]. + ^(self defineSlink: name value_: addr) translateRvalue: self. ] Compiler xCompile: form @@ -952,10 +992,15 @@ Compiler postProcess: aFunction [ pos "----------------------------------------------------------------" -Compiler compile: anObject for: codeGeneratorType +Compiler compile: anObject +[ + ^self compile: anObject for: generatorType with: environment +] + +Compiler compile: anObject for: codeGeneratorType with: anEnvironment [ | block entry tree gen | - self := self withGeneratorType: codeGeneratorType. + self := self withGeneratorType: codeGeneratorType withEnvironment: anEnvironment. (block := Block new) add: (entry := self newLabel); add: ENTER new. @@ -981,7 +1026,12 @@ Compiler compile: anObject for: codeGene Object compile [ - Compiler compile: self for: CodeGenerator default static + ^self compileWith: SlinkEnvironment new +] + +Object compileWith: anEnvironment +[ + Compiler compile: self for: CodeGenerator default static with: anEnvironment ] Object eval @@ -993,7 +1043,7 @@ Object _eval [ | entry value | CompilerOptions verboseList ifTrue: [self compile]. - entry := Compiler compile: self for: CodeGenerator default dynamic. + entry := Compiler compile: self for: CodeGenerator default dynamic with: TheGlobalEnvironment. value := entry call. entry free. ^value diff -r 1e71558180f0 function/jolt2/Instruction.st --- a/function/jolt2/Instruction.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/Instruction.st Fri Apr 25 16:12:06 2008 -0600 @@ -511,6 +511,8 @@ INDIRI2 : Unary () INDIRI2 name [ ^#ind INDIRI2 : Unary () INDIRI2 name [ ^#indiri2 ] INDIRI4 : Unary () INDIRI4 name [ ^#indiri4 ] LEI4 : Binary () LEI4 name [ ^#lei4 ] +SLINK : Leaf () SLINK name [ ^#slink ] +SLINKI : Leaf () SLINKI name [ ^#slinki ] LTI4 : Binary () LTI4 name [ ^#lti4 ] MODI4 : Binary () MODI4 name [ ^#modi4 ] MULI4 : Binary () MULI4 name [ ^#muli4 ] diff -r 1e71558180f0 function/jolt2/boot.k --- a/function/jolt2/boot.k Thu Apr 24 23:17:10 2008 -0600 +++ b/function/jolt2/boot.k Fri Apr 25 16:12:06 2008 -0600 @@ -157,6 +157,7 @@ (lambda (path) (let ((file [File openIfPresent: [String value_: path]])) (or file (set file [File openIfPresent: [[[Options libdir] , '"/"] , [String value_: path]]])) + (or file (set file [File openIfPresent: [[[Options progdir] , '"/"] , [String value_: path]]])) (if file (let () (herald path) @@ -227,6 +228,10 @@ (load "object.k") (define *package-list* [IdentitySet new]) +[*package-list* add: 'syntax] +[*package-list* add: 'debug] +[*package-list* add: 'object] +[*package-list* add: 'boot] (define %require (lambda (package) diff -r 1e71558180f0 function/objects/File.st --- a/function/objects/File.st Thu Apr 24 23:17:10 2008 -0600 +++ b/function/objects/File.st Fri Apr 25 16:12:06 2008 -0600 @@ -22,6 +22,8 @@ { include "tag.h" } +{ include <errno.h> } + File : Object ( _fd name ) File isFile [ ^true ] @@ -54,6 +56,7 @@ File println: anObject [ self print: File println: anObject [ self print: anObject; cr ] File print: aNumber base: base [ aNumber printOn: self base: base ] File print: aNumber base: base width: width [ aNumber printOn: self base: base width: width ] +File print_x: o [ self print: (Integer value_: o) base: 16 ] File cr [ self nextPut: $\n ] File cr: n [ n timesRepeat: [self cr] ] File space [ self nextPut: $ ] @@ -77,15 +80,23 @@ File next: size putAll: aString | _bytes _size | _bytes := aString _bytes. _size := size _integerValue. - { _return _O(write((int)self->v__fd, (void *)v__bytes, (size_t)v__size)); }. -] - -File print_x: _pointer -{ - char buf[1024]; - int size= sprintf(buf, "%x", (int)v__pointer); - _return _O(write((int)self->v__fd, (void *)buf, (size_t)size)); -} + { + size_t position= 0; + size_t remaining= (size_t)v__size; + while (remaining) + { + int count= write((int)self->v__fd, ((char *)v__bytes) + position, remaining); + if (count >= 0) + { + position += count; + remaining -= count; + } + else if (errno != EINTR) + break; + } + _return _O(position); + } +] File read: aCollection [ ^self read: aCollection size: aCollection size ] File read: aCollection size: size [ ^self read: aCollection at: 0 size: size ]
_______________________________________________ fonc mailing list fonc@vpri.org http://vpri.org/mailman/listinfo/fonc