From 22dc528bcebd30bd8a274fca0d7d728e917c7ec2 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 11:38:09 +0200 Subject: MLKForm class cluster: Add a couple of accessors to forms that are only processed indirectly. --- MLKForm.h | 8 ++++++++ MLKForm.m | 26 ++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/MLKForm.h b/MLKForm.h index 29483ef..ac08241 100644 --- a/MLKForm.h +++ b/MLKForm.h @@ -91,6 +91,7 @@ { id _body; NSArray *_bodyForms; + id _bodyContext; } -(void) splitDeclarationsAndBody:(id)object; @@ -319,6 +320,10 @@ } +(Class) dispatchClassForObject:(id)object; + +-(id) name; +-(id) lambdaListName; +-(id) bodyForms; @end @@ -329,6 +334,9 @@ } +(Class) dispatchClassForObject:(id)object; + +-(id) name; +-(id) valueForm; @end diff --git a/MLKForm.m b/MLKForm.m index a5bebe5..b7be502 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -246,6 +246,7 @@ rest = [rest cdr]; } + LASSIGN (_bodyContext, context); LASSIGN (_bodyForms, bodyForms); } @@ -883,6 +884,21 @@ inContext:newContext]; return self; } + +-(id) name +{ + return _name; +} + +-(id) lambdaListName +{ + return _lambdaListName; +} + +-(id) bodyForms +{ + return _bodyForms; +} @end @@ -914,6 +930,16 @@ { return [[super subforms] arrayByAddingObject:_valueForm]; } + +-(id) name +{ + return _name; +} + +-(id) valueForm +{ + return _valueForm; +} @end -- cgit v1.2.3 From a94e4b4aac13cae9dd71a5e7c09ae863b9a7219b Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 12:00:07 +0200 Subject: MLKLexicalContext: Declare malloc(3) by including stdlib.h. --- MLKLexicalContext.m | 2 ++ 1 file changed, 2 insertions(+) diff --git a/MLKLexicalContext.m b/MLKLexicalContext.m index 1eaa51c..2af717b 100644 --- a/MLKLexicalContext.m +++ b/MLKLexicalContext.m @@ -37,6 +37,8 @@ #import "runtime-compatibility.h" #import "util.h" +#include + #define MAKE_ENVIRONMENT(variable, parent, parent_member) \ [[MLKEnvironment alloc] \ -- cgit v1.2.3 From f24c4a95ab655cf47bcea1a2f20b6a1f76329c68 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 12:00:52 +0200 Subject: LLVM compiler: Implement LET. --- MLKLLVMCompiler.mm | 42 +++++++++++++++++++++++++++++++++++++----- 1 file changed, 37 insertions(+), 5 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 4313ac9..3b011d5 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -126,7 +126,7 @@ static Constant // JIT-compile. fn = (id (*)()) execution_engine->getPointerToFunction (function); - module->dump(); + //module->dump(); NSLog (@"%p", fn); // Execute. @@ -314,10 +314,7 @@ static Constant { NSEnumerator *e = [_bodyForms objectEnumerator]; MLKForm *form; - Value *value = NULL; - - if ([_bodyForms count] == 0) - value = ConstantPointerNull::get (PointerTy); + Value *value = ConstantPointerNull::get (PointerTy); while ((form = [e nextObject])) { @@ -405,6 +402,9 @@ static Constant args.push_back ([form processForLLVM]); } + //GlobalVariable *endmarker = module->getGlobalVariable ("MLKEndOfArgumentsMarker", false); + //endmarker->setConstant (true); + //GlobalVariable *endmarker = new GlobalVariable (PointerTy, true, GlobalValue::ExternalWeakLinkage); Value *endmarker = builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, (uint64_t)MLKEndOfArgumentsMarker, false), @@ -569,3 +569,35 @@ static Constant return closure; } @end + + +@implementation MLKLetForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + NSEnumerator *e = [_variableBindingForms objectEnumerator]; + Value *value = ConstantPointerNull::get (PointerTy); + MLKForm *form; + MLKVariableBindingForm *binding_form; + + while ((binding_form = [e nextObject])) + { + // FIXME: Handle heap allocation. + Value *binding_value = [[binding_form valueForm] processForLLVM]; + Value *binding_variable = builder.CreateAlloca (PointerTy, + NULL, + [(MLKPrintToString([binding_form name])) + UTF8String]); + builder.CreateStore (binding_value, binding_variable); + [_bodyContext setValueValue:binding_variable + forSymbol:[binding_form name]]; + } + + e = [_bodyForms objectEnumerator]; + while ((form = [e nextObject])) + { + value = [form processForLLVM]; + } + + return value; +} +@end -- cgit v1.2.3 From 68ce22adad85ff1ea04455b466f656ea6b175a5f Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 12:12:30 +0200 Subject: LLVM compiler: Implement QUOTE. --- MLKLLVMCompiler.mm | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 3b011d5..7767d48 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -601,3 +601,14 @@ static Constant return value; } @end + + +@implementation MLKQuoteForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + return builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)_quotedData, + false), + PointerTy); +} +@end -- cgit v1.2.3 From 99519955fca324cf190116f7fbae5eecbf493077 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 13:08:45 +0200 Subject: MLKForm class cluster: Fix handling of fixnums. --- MLKForm.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/MLKForm.m b/MLKForm.m index b7be502..acf204e 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -56,7 +56,7 @@ +(Class) dispatchClassForObject:(id)object { - if ([object isKindOfClass:[MLKCons class]]) + if (MLKInstanceP (object) && [object isKindOfClass:[MLKCons class]]) return [MLKCompoundForm class]; else return [MLKAtomicForm class]; @@ -89,7 +89,7 @@ @implementation MLKAtomicForm +(Class) dispatchClassForObject:(id)object { - if ([object isKindOfClass:[MLKSymbol class]]) + if (MLKInstanceP (object) && [object isKindOfClass:[MLKSymbol class]]) return [MLKSymbolForm class]; else return [MLKSelfEvaluatingForm class]; -- cgit v1.2.3 From da47da35f268416e1131fa4e107e32fa6a667ae4 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 13:09:08 +0200 Subject: LLVM compiler: Implement IF and support self-evaluating forms. --- MLKLLVMCompiler.mm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 7767d48..81aa764 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -18,6 +18,7 @@ #import "MLKLLVMCompiler.h" #import "globals.h" +#import "util.h" #import #import @@ -606,9 +607,61 @@ static Constant @implementation MLKQuoteForm (MLKLLVMCompilation) -(Value *) processForLLVM { + // FIXME: When to release _quotedData? At the same time the code is + // released, probably... + LRETAIN (_quotedData); return builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, (uint64_t)_quotedData, false), PointerTy); } @end + + +@implementation MLKSelfEvaluatingForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + // FIXME: When to release _form? At the same time the code is + // released, probably... + LRETAIN (_form); + return builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)_form, + false), + PointerTy); +} +@end + + +@implementation MLKIfForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + Function *function = builder.GetInsertBlock()->getParent(); + BasicBlock *thenBlock = BasicBlock::Create ("if_then", function); + BasicBlock *elseBlock = BasicBlock::Create ("if_else"); + BasicBlock *joinBlock = BasicBlock::Create ("if_join"); + + Value *thenValue, *elseValue; + + Value *test = builder.CreateICmpNE ([_conditionForm processForLLVM], + ConstantPointerNull::get (PointerTy)); + builder.CreateCondBr (test, thenBlock, elseBlock); + + builder.SetInsertPoint (thenBlock); + thenValue = [_consequentForm processForLLVM]; + builder.CreateBr (joinBlock); + + builder.SetInsertPoint (elseBlock); + function->getBasicBlockList().push_back (elseBlock); + elseValue = [_alternativeForm processForLLVM]; + builder.CreateBr (joinBlock); + + builder.SetInsertPoint (joinBlock); + function->getBasicBlockList().push_back (joinBlock); + + PHINode *value = builder.CreatePHI (PointerTy, "if_result"); + value->addIncoming (thenValue, thenBlock); + value->addIncoming (elseValue, elseBlock); + + return value; +} +@end -- cgit v1.2.3 From c22d1dfba82475d19896c04bd1c217677a97ad6e Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 15:17:57 +0200 Subject: LLVM compiler: Support package TOILET-SYSTEM's intrinsic operations. --- MLKLLVMCompiler.mm | 55 +++++++++++++++++++++++++++++++++++++++++++++--------- functions.h | 3 ++- functions.m | 28 ++++++++++++++++++++++++++- 3 files changed, 75 insertions(+), 11 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 81aa764..aba2bf1 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -17,6 +17,7 @@ */ #import "MLKLLVMCompiler.h" +#import "MLKPackage.h" #import "globals.h" #import "util.h" @@ -381,23 +382,59 @@ static Constant @implementation MLKFunctionCallForm (MLKLLVMCompilation) -(Value *) processForLLVM { + static MLKPackage *sys = [MLKPackage findPackage:@"TOILET-SYSTEM"]; + + BOOL special_dispatch = NO; + Value *functionCell; + Value *functionPtr; + Value *closureDataCell; + Value *closureDataPtr; + std::vector args; + if (![_context symbolNamesFunction:_head]) { - NSLog (@"Compiler: Don't know function %@", MLKPrintToString(_head)); - // XXX Issue a style warning. + if (_head && [_head homePackage] == sys) + { + special_dispatch = YES; + } + else + { + NSLog (@"Compiler: Don't know function %@", MLKPrintToString(_head)); + // XXX Issue a style warning. + } } - Value *functionCell = builder.Insert ([_context functionCellValueForSymbol:_head]); - Value *functionPtr = builder.CreateLoad (functionCell); - Value *closureDataCell = builder.Insert ([_context closureDataPointerValueForSymbol:_head]); - Value *closureDataPtr = builder.CreateLoad (closureDataCell); + if (!special_dispatch) + { + functionCell = builder.Insert ([_context functionCellValueForSymbol:_head]); + functionPtr = builder.CreateLoad (functionCell); + closureDataCell = builder.Insert ([_context closureDataPointerValueForSymbol:_head]); + closureDataPtr = builder.CreateLoad (closureDataCell); + + args.push_back (closureDataPtr); + } + else + { + std::vector argtypes (1, PointerTy); + functionPtr = builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)MLKDispatchRootFunction, + false), + PointerType::get (FunctionType::get (PointerTy, + argtypes, + true), + 0)); + LRETAIN (_head); // FIXME: release sometime? On the other hand, + // these symbols will probably never be + // deallocated anyway. + args.push_back (builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)_head, + false), + PointerTy)); + } NSEnumerator *e = [_argumentForms objectEnumerator]; MLKForm *form; - std::vector args; - args.push_back (closureDataPtr); - while ((form = [e nextObject])) { args.push_back ([form processForLLVM]); diff --git a/functions.h b/functions.h index 8f3e70e..4ea8261 100644 --- a/functions.h +++ b/functions.h @@ -17,6 +17,7 @@ */ #import "MLKInteger.h" +#import "MLKSymbol.h" #import #include @@ -82,7 +83,7 @@ void MLKSetForeignValueWithLispValue (void *destination, id value, MLKForeignTyp id MLKLispValueWithForeignValue (void *source, MLKForeignType type); id MLKInterpretedFunctionTrampoline (void *target, ...); - +id MLKDispatchRootFunction (MLKSymbol *name, ...); #ifdef __cplusplus } diff --git a/functions.m b/functions.m index 7caea41..20cde07 100644 --- a/functions.m +++ b/functions.m @@ -25,7 +25,9 @@ #import "MLKInterpretedClosure.h" #import "MLKPackage.h" #import "MLKSymbol.h" +#import "MLKRoot.h" +#import #import #import @@ -405,7 +407,31 @@ id MLKInterpretedFunctionTrampoline (void *target, ...) values = [closure applyToArray:arguments]; if ([values count] > 0) - return [values objectAtIndex:0]; + return denullify ([values objectAtIndex:0]); + else + return nil; +} + +id MLKDispatchRootFunction (MLKSymbol *name, ...) +{ + NSArray *values; + NSMutableArray *arguments; + id arg; + va_list ap; + + arguments = [NSMutableArray array]; + + va_start (ap, name); + while ((arg = va_arg (ap, id)) != MLKEndOfArgumentsMarker) + { + [arguments addObject:nullify(arg)]; + } + va_end (ap); + + values = [MLKRoot dispatch:name withArguments:arguments]; + + if ([values count] > 0) + return denullify ([values objectAtIndex:0]); else return nil; } -- cgit v1.2.3 From 650385128d0e31777e51d2bc9c1f79f15e966cd8 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 15:19:08 +0200 Subject: MLKCons: Do not crash when displaying a cons whose cdr is a fixnum. --- MLKCons.m | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/MLKCons.m b/MLKCons.m index bee917f..9e49d45 100644 --- a/MLKCons.m +++ b/MLKCons.m @@ -146,7 +146,7 @@ if (!_cdr) return [NSString stringWithFormat:@"%@", MLKPrintToString(_car)]; - else if ([_cdr isKindOfClass:[MLKCons class]]) + else if (MLKInstanceP (_cdr) && [_cdr isKindOfClass:[MLKCons class]]) return [NSString stringWithFormat:@"%@ %@", MLKPrintToString(_car), [_cdr bareDescriptionForLisp]]; @@ -158,7 +158,7 @@ -(NSString *)descriptionForLisp { - if ([_cdr isKindOfClass:[MLKCons class]]) + if (MLKInstanceP (_cdr) && [_cdr isKindOfClass:[MLKCons class]]) { if (_car == [[MLKPackage findPackage:@"COMMON-LISP"] intern:@"QUOTE"]) return [NSString stringWithFormat:@"'%@", [_cdr bareDescriptionForLisp]]; -- cgit v1.2.3 From 975487368a75e6762fa4a7a2721595ba253bd420 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 19:52:16 +0200 Subject: MLKForm class cluster: Fix SETQ and FSETQ (statement order in -complete method). --- MLKForm.m | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/MLKForm.m b/MLKForm.m index acf204e..955aa63 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -734,16 +734,17 @@ @implementation MLKSetQForm -(id) complete { - id rest = _tail; + id rest; NSMutableArray *variables, *valueForms; self = [super complete]; + rest = _tail; variables = [NSMutableArray array]; valueForms = [NSMutableArray array]; while (rest) { - [variables addObject:[rest car]]; + [variables addObject:nullify([rest car])]; [valueForms addObject:MAKE_FORM([[rest cdr] car])]; rest = [[rest cdr] cdr]; } @@ -763,16 +764,17 @@ @implementation MLKFSetQForm -(id) complete { - id rest = _tail; + id rest; NSMutableArray *functionNames, *valueForms; self = [super complete]; + rest = _tail; functionNames = [NSMutableArray array]; valueForms = [NSMutableArray array]; while (rest) { - [functionNames addObject:[rest car]]; + [functionNames addObject:nullify([rest car])]; [valueForms addObject:MAKE_FORM([[rest cdr] car])]; rest = [[rest cdr] cdr]; } -- cgit v1.2.3 From 0c789f22fae8c0d318a189e8b8b73f5e5ef81976 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 19:53:42 +0200 Subject: LLVM compiler: Implement SETQ. --- MLKLLVMCompiler.mm | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index aba2bf1..cfa50c3 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -702,3 +702,38 @@ static Constant return value; } @end + + +@implementation MLKSetQForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + NSEnumerator *var_e, *value_e; + MLKForm *valueForm; + Value *value = ConstantPointerNull::get (PointerTy); + id variable; + + var_e = [_variables objectEnumerator]; + value_e = [_valueForms objectEnumerator]; + while ((valueForm = [value_e nextObject])) + { + variable = [var_e nextObject]; + value = [valueForm processForLLVM]; + if ([_context variableHeapAllocationForSymbol:variable]) + { + Value *binding = builder.CreateLoad ([_context + bindingValueForSymbol:variable]); + std::vector args (1, value); + + [_compiler insertVoidMethodCall:@"setValue:" + onObject:binding + withArgumentVector:&args]; + } + else + { + builder.CreateStore (value, [_context valueValueForSymbol:variable]); + } + } + + return value; +} +@end -- cgit v1.2.3 From 96870ab2cd94ba6e36585837b69048c544e6d6b6 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 22:04:27 +0200 Subject: Promote special operators SET and %FSET to intrinsics. --- MLKForm.h | 16 ---------------- MLKForm.m | 36 ------------------------------------ MLKInterpreter.m | 53 ----------------------------------------------------- MLKPackage.m | 2 +- MLKRoot.m | 31 +++++++++++++++++++++++++++++++ special-symbols.h | 4 ---- 6 files changed, 32 insertions(+), 110 deletions(-) diff --git a/MLKForm.h b/MLKForm.h index ac08241..bf7c41b 100644 --- a/MLKForm.h +++ b/MLKForm.h @@ -282,22 +282,6 @@ @end -@interface MLKSetForm : MLKCompoundForm -{ - MLKForm *_variableForm; - MLKForm *_valueForm; -} -@end - - -@interface MLKFSetForm : MLKCompoundForm -{ - MLKForm *_functionNameForm; - MLKForm *_valueForm; -} -@end - - @interface MLKThrowForm : MLKCompoundForm { MLKForm *_tagForm; diff --git a/MLKForm.m b/MLKForm.m index 955aa63..19e04ac 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -148,8 +148,6 @@ else if (car == QUOTE) return [MLKQuoteForm class]; else if (car == SETQ) return [MLKSetQForm class]; else if (car == _FSETQ) return [MLKFSetQForm class]; - else if (car == SET) return [MLKSetForm class]; - else if (car == _FSET) return [MLKFSetForm class]; else if (car == THROW) return [MLKThrowForm class]; else if (car == UNWIND_PROTECT) return [MLKUnwindProtectForm class]; else return [MLKSimpleCompoundForm class]; @@ -791,40 +789,6 @@ @end -@implementation MLKSetForm --(id) complete -{ - self = [super complete]; - LASSIGN (_variableForm, MAKE_FORM ([_tail car])); - LASSIGN (_valueForm, MAKE_FORM ([[_tail cdr] car])); - return self; -} - --(NSArray *) subforms -{ - return [[[super subforms] arrayByAddingObject:_variableForm] - arrayByAddingObject:_valueForm]; -} -@end - - -@implementation MLKFSetForm --(id) complete -{ - self = [super complete]; - LASSIGN (_functionNameForm, MAKE_FORM ([_tail car])); - LASSIGN (_valueForm, MAKE_FORM ([[_tail cdr] car])); - return self; -} - --(NSArray *) subforms -{ - return [[[super subforms] arrayByAddingObject:_functionNameForm] - arrayByAddingObject:_valueForm]; -} -@end - - @implementation MLKThrowForm -(id) complete { diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 693c742..21adaea 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -1059,59 +1059,6 @@ else RETURN_VALUE (value); } - else if (car == SET) - { - id symbol = [[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - id value = [[self eval:[[[program cdr] cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - - if (expandOnly) - RETURN_VALUE ([MLKCons cons:SET - with:[MLKCons cons:symbol - with:[MLKCons cons:value - with:nil]]]); - - if ([dynamicContext bindingForSymbol:symbol]) - [dynamicContext setValue:value forSymbol:symbol]; - else - [[MLKDynamicContext globalContext] addValue:value - forSymbol:symbol]; - - return [NSArray arrayWithObject:symbol]; - } - else if (car == _FSET) - { - // Like SET, but for the function cell. - id symbol = [[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - id value = [[self eval:[[[program cdr] cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]; - - if (expandOnly) - RETURN_VALUE ([MLKCons cons:_FSET - with:[MLKCons cons:symbol - with:[MLKCons cons:value - with:nil]]]); - - [[MLKLexicalContext globalContext] addFunction:symbol]; - [[MLKLexicalEnvironment globalEnvironment] addFunction:value - forSymbol:symbol]; - - return [NSArray arrayWithObject:symbol]; - } else if (car == THROW) { id catchTag; diff --git a/MLKPackage.m b/MLKPackage.m index acaf6db..9bae8fe 100644 --- a/MLKPackage.m +++ b/MLKPackage.m @@ -101,7 +101,6 @@ static NSMutableDictionary *packages = nil; [cl export:[cl intern:@"VALUES"]]; [cl export:[cl intern:@"EVAL"]]; [cl export:[cl intern:@"SPECIAL"]]; - [cl export:[cl intern:@"SET"]]; [cl export:[cl intern:@"UNWIND-PROTECT"]]; [cl export:[cl intern:@"MULTIPLE-VALUE-CALL"]]; [cl export:[cl intern:@"EVAL-WHEN"]]; @@ -155,6 +154,7 @@ static NSMutableDictionary *packages = nil; [sys export:[sys intern:@"DECLARATIONS-AND-DOC-AND-FORMS"]]; [sys export:[sys intern:@"DECLARATIONS-AND-FORMS"]]; [sys export:[sys intern:@"COMPILE"]]; + [sys export:[sys intern:@"SET"]]; [sys export:[sys intern:@"OBJC-CLASS-OF"]]; [sys export:[sys intern:@"OBJC-SUBCLASSP"]]; diff --git a/MLKRoot.m b/MLKRoot.m index b051dd3..0c59c23 100644 --- a/MLKRoot.m +++ b/MLKRoot.m @@ -99,6 +99,10 @@ static id truify (BOOL value) withString:@"_" options:NSLiteralSearch range:NSMakeRange(0, [methodName length])]; + [methodName replaceOccurrencesOfString:@"%" + withString:@"" + options:NSLiteralSearch + range:NSMakeRange(0, [methodName length])]; [methodName appendString:@":"]; selector = NSSelectorFromString (methodName); @@ -715,4 +719,31 @@ as provided by method %@ of object %@", RETURN_VALUE (thing); } #endif + ++(NSArray *) fset:(NSArray *)args +{ + id symbol = denullify ([args objectAtIndex:0]); + id value = denullify ([args objectAtIndex:1]); + + [[MLKLexicalContext globalContext] addFunction:symbol]; + [[MLKLexicalEnvironment globalEnvironment] addFunction:value + forSymbol:symbol]; + + RETURN_VALUE (value); +} + ++(NSArray *) set:(NSArray *)args +{ + id symbol = denullify ([args objectAtIndex:0]); + id value = denullify ([args objectAtIndex:1]); + MLKDynamicContext *dynamicContext = [MLKDynamicContext currentContext]; + + if ([dynamicContext bindingForSymbol:symbol]) + [dynamicContext setValue:value forSymbol:symbol]; + else + [[MLKDynamicContext globalContext] addValue:value + forSymbol:symbol]; + + RETURN_VALUE (value); +} @end diff --git a/special-symbols.h b/special-symbols.h index fa68ba7..c455025 100644 --- a/special-symbols.h +++ b/special-symbols.h @@ -44,9 +44,7 @@ static MLKSymbol *EVAL_WHEN; static MLKSymbol *QUOTE; static MLKSymbol *SETQ; static MLKSymbol *SETF; -static MLKSymbol *SET; static MLKSymbol *_FSETQ; -static MLKSymbol *_FSET; static MLKSymbol *SYMBOL_MACROLET; static MLKSymbol *PROGV; static MLKSymbol *UNWIND_PROTECT; @@ -95,9 +93,7 @@ ensure_symbols () QUOTE = [cl intern:@"QUOTE"]; SETQ = [cl intern:@"SETQ"]; SETF = [cl intern:@"SETF"]; - SET = [cl intern:@"SET"]; _FSETQ = [sys intern:@"%FSETQ"]; - _FSET = [sys intern:@"%FSET"]; SYMBOL_MACROLET = [cl intern:@"SYMBOL-MACROLET"]; PROGV = [cl intern:@"PROGV"]; VALUES = [cl intern:@"VALUES"]; -- cgit v1.2.3 From 79b29bf6e41ca122d469040cd671d43ce81bd6df Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 22:04:53 +0200 Subject: Formatting. --- MLKLLVMCompiler.mm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index cfa50c3..1fe4f4b 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -706,7 +706,7 @@ static Constant @implementation MLKSetQForm (MLKLLVMCompilation) -(Value *) processForLLVM -{ +{ NSEnumerator *var_e, *value_e; MLKForm *valueForm; Value *value = ConstantPointerNull::get (PointerTy); -- cgit v1.2.3 From d86ccf58d5b462100d1f4ec5d016024543ec7f53 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 22:43:25 +0200 Subject: Replace special operator %DEFMACRO with intrinsic function %MACROSET. --- MLKForm.h | 8 -------- MLKForm.m | 26 -------------------------- MLKInterpreter.m | 40 ---------------------------------------- MLKPackage.m | 2 +- MLKRoot.m | 11 +++++++++++ util.lisp | 11 +++++++++++ 6 files changed, 23 insertions(+), 75 deletions(-) diff --git a/MLKForm.h b/MLKForm.h index bf7c41b..5263dbd 100644 --- a/MLKForm.h +++ b/MLKForm.h @@ -134,14 +134,6 @@ @end -@interface MLKSimpleDefmacroForm : MLKDeclaringForm -{ - MLKSymbol *_lambdaListName; - MLKSymbol *_name; -} -@end - - @interface MLKEvalWhenForm : MLKBodyForm { BOOL _compileToplevel; diff --git a/MLKForm.m b/MLKForm.m index 19e04ac..b255cc9 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -130,7 +130,6 @@ if (car == APPLY) return [MLKFunctionCallForm class]; else if (car == CATCH) return [MLKCatchForm class]; - else if (car == _DEFMACRO) return [MLKSimpleDefmacroForm class]; else if (car == EVAL) return [MLKFunctionCallForm class]; else if (car == EVAL_WHEN) return [MLKEvalWhenForm class]; else if (car == _FOREIGN_LAMBDA) return [MLKForeignLambdaForm class]; @@ -332,31 +331,6 @@ @end -@implementation MLKSimpleDefmacroForm --(id) complete -{ - MLKLexicalContext *newContext; - - self = [super complete]; - - LASSIGN (_name, [_tail car]); - LASSIGN (_lambdaListName, [[_tail cdr] car]); - newContext = [MLKLexicalContext contextWithParent:_context - variables:[NSSet setWithObject:_lambdaListName] - functions:nil - goTags:nil - macros:nil - compilerMacros:nil - symbolMacros:nil - declarations:[self declarationsWithForms:[[_tail cdr] cdr]]]; - - [self processBody:[[_tail cdr] cdr] - inContext:newContext]; - return self; -} -@end - - @implementation MLKEvalWhenForm -(id) complete { diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 21adaea..3f91814 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -289,46 +289,6 @@ return nil; } - else if (car == _DEFMACRO) - { - // No real lambda lists here. This SYS::%DEFMACRO is - // really as low-level as it gets. - id name = [[program cdr] car]; - id lambdaListAndBody = [[program cdr] cdr]; - - id function; - - if (expandOnly) - { - id lambdaList = [lambdaListAndBody car]; - id body = [lambdaListAndBody cdr]; - id body_expansion = - denullify([[self eval:[MLKCons cons:PROGN with:body] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - RETURN_VALUE ([MLKCons - cons:_DEFMACRO - with:[MLKCons - cons:name - with:[MLKCons - cons:lambdaList - with:[MLKCons - cons:body_expansion - with:nil]]]]); - } - - function = denullify([[self eval:[MLKCons cons:_LAMBDA with:lambdaListAndBody] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - - [context addMacro:function forSymbol:name]; - - RETURN_VALUE (name); - } else if (car == EVAL) { NSArray *evaluand = denullify([[self eval:[[program cdr] car] diff --git a/MLKPackage.m b/MLKPackage.m index 9bae8fe..c86f8a6 100644 --- a/MLKPackage.m +++ b/MLKPackage.m @@ -105,10 +105,10 @@ static NSMutableDictionary *packages = nil; [cl export:[cl intern:@"MULTIPLE-VALUE-CALL"]]; [cl export:[cl intern:@"EVAL-WHEN"]]; - [sys export:[sys intern:@"%DEFMACRO"]]; [sys export:[sys intern:@"%LAMBDA"]]; [sys export:[sys intern:@"%FSET"]]; [sys export:[sys intern:@"%FSETQ"]]; + [sys export:[sys intern:@"%MACROSET"]]; [sys export:[sys intern:@"%LOOP"]]; [sys export:[sys intern:@"%FLET"]]; [sys export:[sys intern:@"%MACROLET"]]; diff --git a/MLKRoot.m b/MLKRoot.m index 0c59c23..b12cd17 100644 --- a/MLKRoot.m +++ b/MLKRoot.m @@ -746,4 +746,15 @@ as provided by method %@ of object %@", RETURN_VALUE (value); } + ++(NSArray *) macroset:(NSArray *)args +{ + id symbol = denullify ([args objectAtIndex:0]); + id value = denullify ([args objectAtIndex:1]); + + [[MLKLexicalContext globalContext] addMacro:value + forSymbol:symbol]; + + RETURN_VALUE (value); +} @end diff --git a/util.lisp b/util.lisp index 412b23d..ede7eeb 100644 --- a/util.lisp +++ b/util.lisp @@ -22,6 +22,17 @@ otherwise unless when eq boundp)) +(%macroset '%defmacro + (%lambda args + (let ((form (car args))) + (let ((name (car (cdr form))) + (lambda-list-name (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + (list '%macroset + (list 'quote name) + (cons '%lambda + (cons lambda-list-name body))))))) + (%defmacro %defun args (list '%fset (list 'quote (car (cdr (car args)))) -- cgit v1.2.3 From e7212b465a8d40ae4e5bff112887e3e8c210019f Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 00:51:27 +0200 Subject: MLKForm class cluster: Fix various memory management errors. --- MLKForm.m | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/MLKForm.m b/MLKForm.m index b255cc9..d8f72bc 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -43,9 +43,10 @@ inContext:(MLKLexicalContext *)context forCompiler:(id)compiler { - _form = object; - _context = context; - _compiler = compiler; + self = [super init]; + LASSIGN (_form, object); + LASSIGN (_context, context); + LASSIGN (_compiler, compiler); return [self complete]; } @@ -170,24 +171,24 @@ else if ([_head isKindOfClass:[MLKCons class]]) { LRELEASE (self); - return [MLKForm formWithObject:[MLKCons cons:FUNCALL - with:object] - inContext:context - forCompiler:compiler]; + return LRETAIN ([MLKForm formWithObject:[MLKCons cons:FUNCALL + with:object] + inContext:context + forCompiler:compiler]); } else if ([context symbolNamesMacro:_head]) { LRELEASE (self); - return [MLKMacroCallForm formWithObject:object - inContext:context - forCompiler:compiler]; + return LRETAIN ([MLKMacroCallForm formWithObject:object + inContext:context + forCompiler:compiler]); } else { LRELEASE (self); - return [MLKFunctionCallForm formWithObject:object - inContext:context - forCompiler:compiler]; + return LRETAIN ([MLKFunctionCallForm formWithObject:object + inContext:context + forCompiler:compiler]); } } @@ -215,9 +216,9 @@ _form, context, nil]] objectAtIndex:0]); - return [MLKForm formWithObject:expansion - inContext:context - forCompiler:compiler]; + return LRETAIN ([MLKForm formWithObject:expansion + inContext:context + forCompiler:compiler]); } @end @@ -225,7 +226,7 @@ @implementation MLKBodyForm -(void) splitDeclarationsAndBody:(id)object { - _body = object; + LASSIGN (_body, object); } -(void) processBody:(id)object inContext:(MLKLexicalContext *)context @@ -523,7 +524,7 @@ inContext:newContext forCompiler:_compiler]; LRELEASE (self); //?FIXME - return newForm; + return LRETAIN (newForm); } @end -- cgit v1.2.3 From eade591251f3f3deaa3502d73b6803206fc69d2d Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 00:57:34 +0200 Subject: MLKLLVMCompiler: Add -eval:. --- MLKLLVMCompiler.h | 2 ++ MLKLLVMCompiler.mm | 7 ++++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/MLKLLVMCompiler.h b/MLKLLVMCompiler.h index 379d791..cf2823b 100644 --- a/MLKLLVMCompiler.h +++ b/MLKLLVMCompiler.h @@ -37,6 +37,8 @@ using namespace llvm; +(id) compile:(id)object inContext:(MLKLexicalContext *)context; ++(id) eval:(id)object; + +(void) processTopLevelForm:(id)object; +(void) processTopLevelForm:(id)object inMode:(enum MLKProcessingMode)mode; diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 1fe4f4b..337caf6 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -152,7 +152,12 @@ static Constant //FIXME // If PROGN, do this... If EVAL-WHEN, do that... - +} + ++(id) eval:(id)object +{ + return [self compile:object + inContext:[MLKLexicalContext globalContext]]; } +(Value *) processForm:(MLKForm *)form -- cgit v1.2.3 From fc68a5a5c6b2b8d9b1a841d45b65701d30b4c612 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 00:58:25 +0200 Subject: LLVM compiler: Enclose compilation in an autorelease pool. --- MLKLLVMCompiler.mm | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 337caf6..1d6d471 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -16,12 +16,14 @@ * along with this program. If not, see . */ +#import "MLKDynamicContext.h" #import "MLKLLVMCompiler.h" #import "MLKPackage.h" #import "globals.h" #import "util.h" #import +#import #import #import @@ -102,6 +104,9 @@ static Constant +(id) compile:(id)object inContext:(MLKLexicalContext *)context { + NSAutoreleasePool *pool; + pool = [[NSAutoreleasePool alloc] init]; + Value *v = NULL; BasicBlock *block; std::vector noargs (0, Type::VoidTy); @@ -114,13 +119,14 @@ static Constant module); id lambdaForm; id (*fn)(); + MLKForm *form = [MLKForm formWithObject:object + inContext:context + forCompiler:self]; block = BasicBlock::Create ("entry", function); builder.SetInsertPoint (block); - v = [self processForm:[MLKForm formWithObject:object - inContext:context - forCompiler:self]]; + v = [self processForm:form]; builder.CreateRet (v); verifyFunction (*function); @@ -131,6 +137,9 @@ static Constant //module->dump(); NSLog (@"%p", fn); + [pool release]; + NSLog (@"Code compiled."); + // Execute. lambdaForm = fn(); -- cgit v1.2.3 From 81d52b3cc5a93f031f24e228f87ee47ac4d8299b Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 00:58:40 +0200 Subject: LLVM compiler: Implement IN-PACKAGE. --- MLKLLVMCompiler.mm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index 1d6d471..ae0c083 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -751,3 +751,21 @@ static Constant return value; } @end + + +@implementation MLKInPackageForm (MLKLLVMCompilation) +-(Value *) processForLLVM +{ + id package = [MLKPackage findPackage:stringify(_packageDesignator)]; + + [[MLKDynamicContext currentContext] + setValue:package + forSymbol:[[MLKPackage findPackage:@"COMMON-LISP"] + intern:@"*PACKAGE*"]]; + + return builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)package, + false), + PointerTy); +} +@end -- cgit v1.2.3 From e3dad17e0d389ebd473ed32d38ae8d3387903c36 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 00:59:21 +0200 Subject: special-symbols.h: Remove symbol %DEFMACRO. --- special-symbols.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/special-symbols.h b/special-symbols.h index c455025..9427181 100644 --- a/special-symbols.h +++ b/special-symbols.h @@ -49,7 +49,6 @@ static MLKSymbol *SYMBOL_MACROLET; static MLKSymbol *PROGV; static MLKSymbol *UNWIND_PROTECT; static MLKSymbol *VALUES; -static MLKSymbol *_DEFMACRO; static MLKSymbol *_FOREIGN_LAMBDA; static MLKSymbol *_LAMBDA; static MLKSymbol *_LOOP; @@ -98,7 +97,6 @@ ensure_symbols () PROGV = [cl intern:@"PROGV"]; VALUES = [cl intern:@"VALUES"]; UNWIND_PROTECT = [cl intern:@"UNWIND-PROTECT"]; - _DEFMACRO = [sys intern:@"%DEFMACRO"]; _FOREIGN_LAMBDA = [sys intern:@"%FOREIGN-LAMBDA"]; _LAMBDA = [sys intern:@"%LAMBDA"]; V_INITP = [sys intern:@"*SYSTEM-INITIALISED-P*"]; -- cgit v1.2.3 From a46dd37ba3832c9418c24d4b44f87d72df50585f Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 01:00:01 +0200 Subject: LOAD: Always compile code when loading it. --- MLKInterpreter.m | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 3f91814..540b9b5 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -29,6 +29,7 @@ #import "MLKInterpreter.h" #import "MLKLexicalContext.h" #import "MLKLexicalEnvironment.h" +#import "MLKLLVMCompiler.h" #import "MLKPackage.h" #import "MLKReader.h" #import "MLKRoot.h" @@ -1242,7 +1243,8 @@ if (code == eofValue) break; - if ([code isKindOfClass:[MLKCons class]] && [code cdr]) + if (MLKInstanceP(code) + && [code isKindOfClass:[MLKCons class]] && [code cdr]) formdesc = [NSString stringWithFormat:@"(%@ %@ ...)", MLKPrintToString([code car]), MLKPrintToString([[code cdr] car])]; @@ -1254,6 +1256,11 @@ for (i = 0; i < level; i++) fprintf (stderr, "| "); fprintf (stderr, "LOAD: %s\n", [formdesc UTF8String]); + +#ifdef USE_LLVM + expansion = code; + result = [MLKLLVMCompiler eval:code]; +#else // !USE_LLVM expansion = denullify([[MLKInterpreter eval:code inLexicalContext:[MLKLexicalContext @@ -1277,6 +1284,7 @@ withEnvironment:[MLKLexicalEnvironment globalEnvironment] expandOnly:NO]; //NSLog (@"; LOAD: Top-level form evaluated."); +#endif //!USE_LLVM LRELEASE (pool); -- cgit v1.2.3 From ec1b0c41160ce153f3b2cd39ffeb2f4522fd1c38 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 01:01:53 +0200 Subject: MLKReadEvalPrintLoop: Add debugging options. --- MLKReadEvalPrintLoop.m | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/MLKReadEvalPrintLoop.m b/MLKReadEvalPrintLoop.m index 2ddc5d7..a23ba36 100644 --- a/MLKReadEvalPrintLoop.m +++ b/MLKReadEvalPrintLoop.m @@ -31,6 +31,10 @@ #import #import +#ifdef GNUSTEP +#import +#endif + #import @@ -132,7 +136,13 @@ static const char *prompt (EditLine *e) { if (strcmp (line, ":q\n") == 0 || strncmp (line, ":q ", 3) == 0) break; +#if 1 NS_DURING +#else + GSDebugAllocationActive (YES); + [NSObject enableDoubleReleaseCheck:YES]; + NSZombieEnabled = YES; +#endif { int i; @@ -150,6 +160,7 @@ static const char *prompt (EditLine *e) { printf ("%s\n", [MLKPrintToString (denullify (result)) UTF8String]); } } +#if 1 NS_HANDLER { printf ("Caught an unhandled exception.\nName: %s\nReason: %s\n", @@ -157,6 +168,7 @@ static const char *prompt (EditLine *e) { [[localException reason] UTF8String]); } NS_ENDHANDLER; +#endif LRELEASE (pool); } -- cgit v1.2.3 From bdfe4801295945b92f84b8c03cb2e0be485ae4f0 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 01:19:06 +0200 Subject: Promote special operator APPLY to an intrinsic function. --- MLKForm.m | 3 +-- MLKInterpreter.m | 29 +---------------------------- MLKPackage.m | 2 +- MLKRoot.m | 22 +++++++++++++++++++--- special-symbols.h | 2 -- 5 files changed, 22 insertions(+), 36 deletions(-) diff --git a/MLKForm.m b/MLKForm.m index d8f72bc..ee5139f 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -129,8 +129,7 @@ { id car = [object car]; - if (car == APPLY) return [MLKFunctionCallForm class]; - else if (car == CATCH) return [MLKCatchForm class]; + if (car == CATCH) return [MLKCatchForm class]; else if (car == EVAL) return [MLKFunctionCallForm class]; else if (car == EVAL_WHEN) return [MLKEvalWhenForm class]; else if (car == _FOREIGN_LAMBDA) return [MLKForeignLambdaForm class]; diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 540b9b5..0cdf904 100644 --- a/MLKInterpreter.m +++ b/MLKInterpreter.m @@ -193,34 +193,7 @@ } } - if (car == APPLY) - { - MLKCons *rest = denullify([[self eval:[[[program cdr] cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - - id function = denullify([[self eval:[[program cdr] car] - inLexicalContext:context - withEnvironment:lexenv - expandOnly:expandOnly] - objectAtIndex:0]); - - if (expandOnly) - RETURN_VALUE ([MLKCons cons:APPLY - with:[MLKCons cons:function - with:[MLKCons cons:rest - with:nil]]]); - - if ([function isKindOfClass:[MLKSymbol class]]) - function = [lexenv functionForSymbol:function]; - - return [function applyToArray:(rest - ? (id)[rest array] - : (id)[NSArray array])]; - } - else if (car == CATCH) + if (car == CATCH) { id catchTag; NSArray *values; diff --git a/MLKPackage.m b/MLKPackage.m index c86f8a6..6d97652 100644 --- a/MLKPackage.m +++ b/MLKPackage.m @@ -92,7 +92,6 @@ static NSMutableDictionary *packages = nil; [cl export:[cl intern:@"FUNCALL"]]; [cl export:[cl intern:@"FUNCTION"]]; [cl export:[cl intern:@"PROGN"]]; - [cl export:[cl intern:@"APPLY"]]; [cl export:[cl intern:@"PROGV"]]; [cl export:[cl intern:@"SETQ"]]; [cl export:[cl intern:@"SETF"]]; @@ -155,6 +154,7 @@ static NSMutableDictionary *packages = nil; [sys export:[sys intern:@"DECLARATIONS-AND-FORMS"]]; [sys export:[sys intern:@"COMPILE"]]; [sys export:[sys intern:@"SET"]]; + [sys export:[sys intern:@"APPLY"]]; [sys export:[sys intern:@"OBJC-CLASS-OF"]]; [sys export:[sys intern:@"OBJC-SUBCLASSP"]]; diff --git a/MLKRoot.m b/MLKRoot.m index b12cd17..0db7483 100644 --- a/MLKRoot.m +++ b/MLKRoot.m @@ -711,11 +711,11 @@ as provided by method %@ of object %@", #ifdef USE_LLVM +(NSArray *) compile:(NSArray *)args { - NSLog (@"Compiling lambda form."); + //NSLog (@"Compiling lambda form."); id thing = [MLKLLVMCompiler compile:denullify([args objectAtIndex:0]) inContext:[MLKLexicalContext globalContext]]; - NSLog (@"Compilation done."); - NSLog (@"Compiled: %@", thing); + //NSLog (@"Compilation done."); + //NSLog (@"Compiled: %@", thing); RETURN_VALUE (thing); } #endif @@ -757,4 +757,20 @@ as provided by method %@ of object %@", RETURN_VALUE (value); } + ++(NSArray *) apply:(NSArray *)args +{ + id function = denullify ([args objectAtIndex:0]); + id arglist = denullify ([args objectAtIndex:1]); + + if (!function || [function isKindOfClass:[MLKSymbol class]]) + { + function = [[MLKLexicalEnvironment globalEnvironment] + functionForSymbol:function]; + } + + return [function applyToArray:(arglist + ? (id)[arglist array] + : (id)[NSArray array])]; +} @end diff --git a/special-symbols.h b/special-symbols.h index 9427181..d7e7351 100644 --- a/special-symbols.h +++ b/special-symbols.h @@ -36,7 +36,6 @@ static MLKSymbol *_MACROLET; static MLKSymbol *LAMBDA; static MLKSymbol *LET; static MLKSymbol *LOCALLY; -static MLKSymbol *APPLY; static MLKSymbol *FUNCALL; static MLKSymbol *FUNCTION; static MLKSymbol *EVAL; @@ -84,7 +83,6 @@ ensure_symbols () _FLET = [sys intern:@"%FLET"]; _MACROLET = [sys intern:@"%MACROLET"]; _LOOP = [sys intern:@"%LOOP"]; - APPLY = [cl intern:@"APPLY"]; EVAL = [cl intern:@"EVAL"]; EVAL_WHEN = [cl intern:@"EVAL-WHEN"]; FUNCALL = [cl intern:@"FUNCALL"]; -- cgit v1.2.3 From 60993a5e474244a3f4f623bb81d5191f2ec50993 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 01:20:58 +0200 Subject: LLVM compiler: Disable debugging messages. --- MLKLLVMCompiler.mm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index ae0c083..a7efa12 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -135,15 +135,15 @@ static Constant // JIT-compile. fn = (id (*)()) execution_engine->getPointerToFunction (function); //module->dump(); - NSLog (@"%p", fn); + //NSLog (@"%p", fn); [pool release]; - NSLog (@"Code compiled."); + //NSLog (@"Code compiled."); // Execute. lambdaForm = fn(); - NSLog (@"Closure built."); + //NSLog (@"Closure built."); return lambdaForm; } @@ -586,7 +586,7 @@ static Constant builder.CreateRet (value); - function->dump(); + //function->dump(); //NSLog (@"Verify..."); verifyFunction (*function); //NSLog (@"Optimise..."); @@ -596,7 +596,7 @@ static Constant // the function. execution_engine->getPointerToFunction (function); //NSLog (@"Done."); - function->dump(); + //function->dump(); //NSLog (@"Function built."); builder.SetInsertPoint (outerBlock); -- cgit v1.2.3 From 4447563e79bb32bbda14641733049fe544392917 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 11:38:56 +0200 Subject: LLVM compiler: Implement dynamic variable access. --- MLKLLVMCompiler.mm | 46 ++++++++++++++++++++++++++++++--- MLKLexicalContext-MLKLLVMCompilation.h | 2 +- MLKLexicalContext-MLKLLVMCompilation.mm | 12 ++++++--- MLKLexicalContext.h | 7 +++-- MLKLexicalContext.m | 39 +++++++++++++++++++++++----- MLKLexicalEnvironment.m | 32 ++++++++++++++++++++--- 6 files changed, 115 insertions(+), 23 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index a7efa12..e7dc660 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -132,6 +132,8 @@ static Constant verifyFunction (*function); fpm->run (*function); + //function->dump(); + // JIT-compile. fn = (id (*)()) execution_engine->getPointerToFunction (function); //module->dump(); @@ -377,9 +379,26 @@ static Constant { Value *value; - if ([_context variableHeapAllocationForSymbol:_form]) + if (![_context variableIsLexical:_form]) + { + Value *mlkdynamiccontext = [_compiler insertClassLookup:@"MLKCons"]; + Value *dynctx = [_compiler insertMethodCall:@"currentContext" + onObject:mlkdynamiccontext]; + + LRETAIN (_form); // FIXME: release + Value *symbolV = builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)_form, + false), + PointerTy); + + std::vector args (1, symbolV); + value = [_compiler insertMethodCall:@"valueForSymbol:" + onObject:dynctx + withArgumentVector:&args]; + } + else if ([_context variableHeapAllocationForSymbol:_form]) { - Value *binding = builder.CreateLoad ([_context bindingValueForSymbol:_form]); + Value *binding = builder.CreateLoad (builder.Insert ([_context bindingCellValueForSymbol:_form])); value = [_compiler insertMethodCall:@"value" onObject:binding]; } else @@ -732,10 +751,29 @@ static Constant { variable = [var_e nextObject]; value = [valueForm processForLLVM]; + if (![_context variableIsLexical:variable]) + { + Value *mlkdynamiccontext = [_compiler insertClassLookup:@"MLKCons"]; + Value *dynctx = [_compiler insertMethodCall:@"currentContext" + onObject:mlkdynamiccontext]; + + LRETAIN (variable); // FIXME: release + Value *symbolV = builder.CreateIntToPtr (ConstantInt::get(Type::Int64Ty, + (uint64_t)variable, + false), + PointerTy); + + std::vector args; + args.push_back (value); + args.push_back (symbolV); + [_compiler insertMethodCall:@"setValue:forSymbol:" + onObject:dynctx + withArgumentVector:&args]; + } if ([_context variableHeapAllocationForSymbol:variable]) { - Value *binding = builder.CreateLoad ([_context - bindingValueForSymbol:variable]); + Value *binding = builder.CreateLoad (builder.Insert ([_context + bindingCellValueForSymbol:variable])); std::vector args (1, value); [_compiler insertVoidMethodCall:@"setValue:" diff --git a/MLKLexicalContext-MLKLLVMCompilation.h b/MLKLexicalContext-MLKLLVMCompilation.h index d42140e..d791765 100644 --- a/MLKLexicalContext-MLKLLVMCompilation.h +++ b/MLKLexicalContext-MLKLLVMCompilation.h @@ -37,7 +37,7 @@ using namespace llvm; -(BOOL) variableHeapAllocationForSymbol:(id)name; -(Instruction *) functionCellValueForSymbol:(id)name; -(Instruction *) closureDataPointerValueForSymbol:(id)name; --(Value *) bindingValueForSymbol:(id)name; +-(Instruction *) bindingCellValueForSymbol:(id)name; -(Value *) valueValueForSymbol:(id)name; //-(void) setFunctionCellValue:(Value *)cellPtr forSymbol:(id)name; //-(void) setClosureDataPointerValue:(Value *)pointer forSymbol:(id)name; diff --git a/MLKLexicalContext-MLKLLVMCompilation.mm b/MLKLexicalContext-MLKLLVMCompilation.mm index 744351a..22d211d 100644 --- a/MLKLexicalContext-MLKLLVMCompilation.mm +++ b/MLKLexicalContext-MLKLLVMCompilation.mm @@ -45,7 +45,11 @@ using namespace std; id flag = [self deepPropertyForVariable:name key:@"LLVM.heap-flag"]; - return (flag && [flag boolValue]); + if (flag) + return [flag boolValue]; + else + return (![self contextForVariable:name] + || [self contextForVariable:name] == [MLKLexicalContext globalContext]); } -(Instruction *) functionCellValueForSymbol:(id)name @@ -70,12 +74,12 @@ using namespace std; PointerType::get(PointerType::get(Type::Int8Ty, 0), 0))); } --(Value *) bindingValueForSymbol:(id)name +-(Instruction *) bindingCellValueForSymbol:(id)name { return (new IntToPtrInst (ConstantInt::get(Type::Int64Ty, - (uint64_t)[self bindingForSymbol:name], + (uint64_t)[self bindingCellForSymbol:name], false), - PointerType::get(Type::Int8Ty, 0))); + PointerType::get(PointerType::get(Type::Int8Ty, 0), 0))); } -(Value *) valueValueForSymbol:(id)name diff --git a/MLKLexicalContext.h b/MLKLexicalContext.h index fc2abc3..e350b63 100644 --- a/MLKLexicalContext.h +++ b/MLKLexicalContext.h @@ -86,9 +86,8 @@ -(id) declarations; -(void) addDeclaration:(id)declaration; -// FIXME? -//-(MLKLexicalEnvironment *) instantiateWithVariables:(NSDictionary *)variables -// functions:(NSDictionary *)functions; +-(id) contextForVariable:(MLKSymbol *)symbol; +-(id) contextForFunction:(MLKSymbol *)symbol; -(void) addVariable:(MLKSymbol *)symbol; -(void) addFunction:(MLKSymbol *)symbol; @@ -107,7 +106,7 @@ -(void *) functionCellForSymbol:(id)name; -(void *) closureDataPointerForSymbol:(id)name; --(id) bindingForSymbol:(id)name; +-(id *) bindingCellForSymbol:(id)name; -(void) dealloc; @end diff --git a/MLKLexicalContext.m b/MLKLexicalContext.m index 2af717b..3f820a8 100644 --- a/MLKLexicalContext.m +++ b/MLKLexicalContext.m @@ -198,9 +198,29 @@ static MLKSymbol *LEXICAL; with:_declarations]); } +-(id) contextForVariable:(MLKSymbol *)symbol +{ + if ([_variables containsObject:nullify(symbol)]) + return self; + else if (_parent) + return [_parent contextForVariable:symbol]; + else + return nil; +} + +-(id) contextForFunction:(MLKSymbol *)symbol +{ + if ([_functions containsObject:nullify(symbol)]) + return self; + else if (_parent) + return [_parent contextForFunction:symbol]; + else + return nil; +} + -(BOOL) symbolNamesFunction:(MLKSymbol *)symbol { - symbol = symbol ? (id)symbol : (id)[NSNull null]; + symbol = nullify (symbol); if ([_functions containsObject:symbol]) return YES; else if ([_knownMacros containsObject:symbol]) @@ -211,7 +231,7 @@ static MLKSymbol *LEXICAL; -(BOOL) symbolNamesMacro:(MLKSymbol *)symbol { - symbol = symbol ? (id)symbol : (id)[NSNull null]; + symbol = nullify (symbol); if ([_functions containsObject:symbol]) return NO; else if ([_knownMacros containsObject:symbol]) @@ -222,7 +242,7 @@ static MLKSymbol *LEXICAL; -(BOOL) symbolNamesSymbolMacro:(MLKSymbol *)symbol { - symbol = symbol ? (id)symbol : (id)[NSNull null]; + symbol = nullify (symbol); if ([_variables containsObject:symbol]) return NO; else if ([_knownSymbolMacros containsObject:symbol]) @@ -401,20 +421,25 @@ static MLKSymbol *LEXICAL; } } --(id) bindingForSymbol:(id)name +-(id *) bindingCellForSymbol:(id)name { id prop = [self deepPropertyForVariable:name key:@"LEXCTX.variable-binding"]; if (!prop) { - prop = [MLKBinding binding]; + id *cell = malloc (sizeof(id)); + *cell = [[MLKBinding alloc] init]; + prop = [NSValue valueWithPointer:cell]; [self setDeepProperty:prop forVariable:name key:@"LEXCTX.variable-binding"]; + return cell; + } + else + { + return [prop pointerValue]; } - - return prop; } -(void) dealloc diff --git a/MLKLexicalEnvironment.m b/MLKLexicalEnvironment.m index ca6b4a9..723c955 100644 --- a/MLKLexicalEnvironment.m +++ b/MLKLexicalEnvironment.m @@ -107,17 +107,43 @@ static MLKLexicalEnvironment *global_environment; -(id) valueForSymbol:(MLKSymbol *)symbol { - return [_variables valueForSymbol:symbol]; + if (![_variables environmentForSymbol:symbol] + || [_variables environmentForSymbol:symbol] == global_environment->_variables) + { + id *cell = [[MLKLexicalContext globalContext] bindingCellForSymbol:symbol]; + return [*cell value]; + } + else + { + return [_variables valueForSymbol:symbol]; + } } -(void) setValue:(id)value forSymbol:(MLKSymbol *)symbol { - [_variables setValue:value forSymbol:symbol]; + if (![_variables environmentForSymbol:symbol] + || [_variables environmentForSymbol:symbol] == global_environment->_variables) + { + id *cell = [[MLKLexicalContext globalContext] bindingCellForSymbol:symbol]; + [*cell setValue:value forSymbol:symbol]; + } + else + { + [_variables setValue:value forSymbol:symbol]; + } } -(void) addValue:(id)value forSymbol:(MLKSymbol *)symbol { - [_variables addValue:value forSymbol:symbol]; + if (self == global_environment) + { + id *cell = [[MLKLexicalContext globalContext] bindingCellForSymbol:symbol]; + [*cell setValue:value forSymbol:symbol]; + } + else + { + [_variables addValue:value forSymbol:symbol]; + } } -(void) addBindingForSymbol:(MLKSymbol *)symbol -- cgit v1.2.3 From abd832ea8110988b15191c0ed79456737e86ce44 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Fri, 15 Aug 2008 23:24:58 +0200 Subject: init.lisp: Add basic compiler tests. --- init.lisp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/init.lisp b/init.lisp index 71a4211..6799826 100644 --- a/init.lisp +++ b/init.lisp @@ -18,6 +18,10 @@ (in-package #:common-lisp) +(%fset 'test (compile '(sys::%lambda args))) +(ns-log (test)) +(%fset 'test (compile '(sys::%lambda args args))) + (load "util.lisp") (load "defun-0.lisp") (load "list-functions.lisp") -- cgit v1.2.3 From 0e0074e2793c7c899c97ade8f40d44b6c922c487 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sat, 16 Aug 2008 15:29:12 +0200 Subject: init.lisp: Test only the compiler. --- init.lisp | 47 ++++++++++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/init.lisp b/init.lisp index 6799826..73587d5 100644 --- a/init.lisp +++ b/init.lisp @@ -19,37 +19,38 @@ (in-package #:common-lisp) (%fset 'test (compile '(sys::%lambda args))) -(ns-log (test)) +(ns-log (test 'a 'b 'c)) (%fset 'test (compile '(sys::%lambda args args))) +(ns-log (test 1 2 3)) -(load "util.lisp") -(load "defun-0.lisp") -(load "list-functions.lisp") -(load "destructuring-bind.lisp") -(load "defun-1.lisp") -(load "list-functions.lisp") -(load "reader.lisp") -(load "sharpsign.lisp") -(load "control-flow.lisp") -(load "types.lisp") -(load "numbers.lisp") -(load "list-functions-2.lisp") -(load "ffi.lisp") +;; (load "util.lisp") +;; (load "defun-0.lisp") +;; (load "list-functions.lisp") +;; (load "destructuring-bind.lisp") +;; (load "defun-1.lisp") +;; (load "list-functions.lisp") +;; (load "reader.lisp") +;; (load "sharpsign.lisp") +;; (load "control-flow.lisp") +;; (load "types.lisp") +;; (load "numbers.lisp") +;; (load "list-functions-2.lisp") +;; (load "ffi.lisp") -(load "Sacla/share.lisp") -(load "Sacla/do.lisp") +;; (load "Sacla/share.lisp") +;; (load "Sacla/do.lisp") -(load "evaluation.lisp") +;; (load "evaluation.lisp") -(load "Sacla/share-2.lisp") +;; (load "Sacla/share-2.lisp") -(load "Sacla/data-and-control.lisp") +;; (load "Sacla/data-and-control.lisp") -(load "array.lisp") -(load "Sacla/array.lisp") +;; (load "array.lisp") +;; (load "Sacla/array.lisp") -(load "string.lisp") -(load "package.lisp") +;; (load "string.lisp") +;; (load "package.lisp") (setq *system-initialised-p* t) -- cgit v1.2.3 From f6ef23a5f5367ac2bf8ff8d946e6554fbd77febc Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sat, 16 Aug 2008 18:40:33 +0200 Subject: init.lisp: Add a function call test. --- init.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/init.lisp b/init.lisp index 73587d5..0891c5e 100644 --- a/init.lisp +++ b/init.lisp @@ -22,6 +22,8 @@ (ns-log (test 'a 'b 'c)) (%fset 'test (compile '(sys::%lambda args args))) (ns-log (test 1 2 3)) +(%fset 'test2 (compile '(sys::%lambda args (test args)))) +(ns-log (test2 1 2 3)) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 895d77b4c03ec8553dbe29fa487b2024ec466ab6 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 12:01:29 +0200 Subject: init.lisp: Test PROGN and LET. --- init.lisp | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/init.lisp b/init.lisp index 0891c5e..b5454e6 100644 --- a/init.lisp +++ b/init.lisp @@ -20,10 +20,16 @@ (%fset 'test (compile '(sys::%lambda args))) (ns-log (test 'a 'b 'c)) -(%fset 'test (compile '(sys::%lambda args args))) -(ns-log (test 1 2 3)) -(%fset 'test2 (compile '(sys::%lambda args (test args)))) +(%fset 'test2 (compile '(sys::%lambda args args))) (ns-log (test2 1 2 3)) +(%fset 'test3 (compile '(sys::%lambda args (test args)))) +(ns-log (test3 1 2 3)) +(%fset 'test4 (compile '(sys::%lambda args (progn args args args)))) +(ns-log (test4 1 2 3)) +(%fset 'test5 (compile '(sys::%lambda args (let ((x args) + (y args)) + args x y)))) +(ns-log (test5 1 2 3)) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 04eec3a4532b7426c1cdee08b95f3ae658d07ae5 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 12:13:03 +0200 Subject: init.lisp: Test QUOTE. --- init.lisp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/init.lisp b/init.lisp index b5454e6..70a5aea 100644 --- a/init.lisp +++ b/init.lisp @@ -30,6 +30,10 @@ (y args)) args x y)))) (ns-log (test5 1 2 3)) +(%fset 'test6 (compile '(sys::%lambda args (let ((x 'value-x) + (y 'value-y)) + args x y)))) +(ns-log (test6 1 2 3)) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 173e0143fe9930772e405d611f58f72f6f49a7f4 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 13:09:29 +0200 Subject: init.lisp: Test IF. --- init.lisp | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/init.lisp b/init.lisp index 70a5aea..b7b9d99 100644 --- a/init.lisp +++ b/init.lisp @@ -34,6 +34,13 @@ (y 'value-y)) args x y)))) (ns-log (test6 1 2 3)) +(%fset 'test7 (compile '(sys::%lambda args (let ((x nil)) (if x 'yes 'no))))) +(ns-log (test7 1 2 3)) +(%fset 'test8 (compile '(sys::%lambda args (let ((x 100)) (if x 'yes 'no))))) +(ns-log (test8 1 2 3)) +(%fset 'test9 (compile '(sys::%lambda args (if args 'some-args 'no-args)))) +(ns-log (test9)) +(ns-log (test9 1 2 3)) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From f3e77debaacf3e967c046d77169c529790ff1fc9 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 15:19:29 +0200 Subject: init.lisp: Test the CONS intrinsic. --- init.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/init.lisp b/init.lisp index b7b9d99..90a4911 100644 --- a/init.lisp +++ b/init.lisp @@ -41,6 +41,8 @@ (%fset 'test9 (compile '(sys::%lambda args (if args 'some-args 'no-args)))) (ns-log (test9)) (ns-log (test9 1 2 3)) +(%fset 'test10 (compile '(sys::%lambda args (cons 1 2)))) +(ns-log (test10)) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 32a1c8b32efe22d957539b94c0dd69d202e34754 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 17 Aug 2008 22:04:39 +0200 Subject: init.lisp: Test SETQ. --- init.lisp | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/init.lisp b/init.lisp index 90a4911..8114103 100644 --- a/init.lisp +++ b/init.lisp @@ -43,6 +43,14 @@ (ns-log (test9 1 2 3)) (%fset 'test10 (compile '(sys::%lambda args (cons 1 2)))) (ns-log (test10)) +(%fset 'test11 (compile '(sys::%lambda args + (let ((x 'outer)) + (let ((x 'inner)) + (ns-log x) + (setq x 'new-inner) + (ns-log x)) + (ns-log x))))) +(test11) ;; (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 16183c31907ea7cac323f13f90482f3c27b5e7a0 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 01:00:41 +0200 Subject: init.lisp: Test simple top-level forms and load util.lisp. --- init.lisp | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/init.lisp b/init.lisp index 8114103..bf53455 100644 --- a/init.lisp +++ b/init.lisp @@ -18,6 +18,10 @@ (in-package #:common-lisp) +100 + +(ns-log 100) + (%fset 'test (compile '(sys::%lambda args))) (ns-log (test 'a 'b 'c)) (%fset 'test2 (compile '(sys::%lambda args args))) @@ -52,7 +56,7 @@ (ns-log x))))) (test11) -;; (load "util.lisp") +(load "util.lisp") ;; (load "defun-0.lisp") ;; (load "list-functions.lisp") ;; (load "destructuring-bind.lisp") -- cgit v1.2.3 From 920c7a6e0bde3f88a6f120d3a11021fbb60807a4 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 11:39:51 +0200 Subject: init.lisp: Disable simple tests. --- init.lisp | 70 +++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/init.lisp b/init.lisp index bf53455..49bf747 100644 --- a/init.lisp +++ b/init.lisp @@ -18,43 +18,43 @@ (in-package #:common-lisp) -100 +;; 100 -(ns-log 100) +;; (ns-log 100) -(%fset 'test (compile '(sys::%lambda args))) -(ns-log (test 'a 'b 'c)) -(%fset 'test2 (compile '(sys::%lambda args args))) -(ns-log (test2 1 2 3)) -(%fset 'test3 (compile '(sys::%lambda args (test args)))) -(ns-log (test3 1 2 3)) -(%fset 'test4 (compile '(sys::%lambda args (progn args args args)))) -(ns-log (test4 1 2 3)) -(%fset 'test5 (compile '(sys::%lambda args (let ((x args) - (y args)) - args x y)))) -(ns-log (test5 1 2 3)) -(%fset 'test6 (compile '(sys::%lambda args (let ((x 'value-x) - (y 'value-y)) - args x y)))) -(ns-log (test6 1 2 3)) -(%fset 'test7 (compile '(sys::%lambda args (let ((x nil)) (if x 'yes 'no))))) -(ns-log (test7 1 2 3)) -(%fset 'test8 (compile '(sys::%lambda args (let ((x 100)) (if x 'yes 'no))))) -(ns-log (test8 1 2 3)) -(%fset 'test9 (compile '(sys::%lambda args (if args 'some-args 'no-args)))) -(ns-log (test9)) -(ns-log (test9 1 2 3)) -(%fset 'test10 (compile '(sys::%lambda args (cons 1 2)))) -(ns-log (test10)) -(%fset 'test11 (compile '(sys::%lambda args - (let ((x 'outer)) - (let ((x 'inner)) - (ns-log x) - (setq x 'new-inner) - (ns-log x)) - (ns-log x))))) -(test11) +;; (%fset 'test (compile '(sys::%lambda args))) +;; (ns-log (test 'a 'b 'c)) +;; (%fset 'test2 (compile '(sys::%lambda args args))) +;; (ns-log (test2 1 2 3)) +;; (%fset 'test3 (compile '(sys::%lambda args (test args)))) +;; (ns-log (test3 1 2 3)) +;; (%fset 'test4 (compile '(sys::%lambda args (progn args args args)))) +;; (ns-log (test4 1 2 3)) +;; (%fset 'test5 (compile '(sys::%lambda args (let ((x args) +;; (y args)) +;; args x y)))) +;; (ns-log (test5 1 2 3)) +;; (%fset 'test6 (compile '(sys::%lambda args (let ((x 'value-x) +;; (y 'value-y)) +;; args x y)))) +;; (ns-log (test6 1 2 3)) +;; (%fset 'test7 (compile '(sys::%lambda args (let ((x nil)) (if x 'yes 'no))))) +;; (ns-log (test7 1 2 3)) +;; (%fset 'test8 (compile '(sys::%lambda args (let ((x 100)) (if x 'yes 'no))))) +;; (ns-log (test8 1 2 3)) +;; (%fset 'test9 (compile '(sys::%lambda args (if args 'some-args 'no-args)))) +;; (ns-log (test9)) +;; (ns-log (test9 1 2 3)) +;; (%fset 'test10 (compile '(sys::%lambda args (cons 1 2)))) +;; (ns-log (test10)) +;; (%fset 'test11 (compile '(sys::%lambda args +;; (let ((x 'outer)) +;; (let ((x 'inner)) +;; (ns-log x) +;; (setq x 'new-inner) +;; (ns-log x)) +;; (ns-log x))))) +;; (test11) (load "util.lisp") ;; (load "defun-0.lisp") -- cgit v1.2.3 From 54e6d82b6e98065da3d66460cc51530cc7b0493d Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 11:40:51 +0200 Subject: init.lisp: Restore the normal loading sequence. --- init.lisp | 80 +++++++++++++++++---------------------------------------------- 1 file changed, 21 insertions(+), 59 deletions(-) diff --git a/init.lisp b/init.lisp index 49bf747..71a4211 100644 --- a/init.lisp +++ b/init.lisp @@ -18,72 +18,34 @@ (in-package #:common-lisp) -;; 100 - -;; (ns-log 100) - -;; (%fset 'test (compile '(sys::%lambda args))) -;; (ns-log (test 'a 'b 'c)) -;; (%fset 'test2 (compile '(sys::%lambda args args))) -;; (ns-log (test2 1 2 3)) -;; (%fset 'test3 (compile '(sys::%lambda args (test args)))) -;; (ns-log (test3 1 2 3)) -;; (%fset 'test4 (compile '(sys::%lambda args (progn args args args)))) -;; (ns-log (test4 1 2 3)) -;; (%fset 'test5 (compile '(sys::%lambda args (let ((x args) -;; (y args)) -;; args x y)))) -;; (ns-log (test5 1 2 3)) -;; (%fset 'test6 (compile '(sys::%lambda args (let ((x 'value-x) -;; (y 'value-y)) -;; args x y)))) -;; (ns-log (test6 1 2 3)) -;; (%fset 'test7 (compile '(sys::%lambda args (let ((x nil)) (if x 'yes 'no))))) -;; (ns-log (test7 1 2 3)) -;; (%fset 'test8 (compile '(sys::%lambda args (let ((x 100)) (if x 'yes 'no))))) -;; (ns-log (test8 1 2 3)) -;; (%fset 'test9 (compile '(sys::%lambda args (if args 'some-args 'no-args)))) -;; (ns-log (test9)) -;; (ns-log (test9 1 2 3)) -;; (%fset 'test10 (compile '(sys::%lambda args (cons 1 2)))) -;; (ns-log (test10)) -;; (%fset 'test11 (compile '(sys::%lambda args -;; (let ((x 'outer)) -;; (let ((x 'inner)) -;; (ns-log x) -;; (setq x 'new-inner) -;; (ns-log x)) -;; (ns-log x))))) -;; (test11) - (load "util.lisp") -;; (load "defun-0.lisp") -;; (load "list-functions.lisp") -;; (load "destructuring-bind.lisp") -;; (load "defun-1.lisp") -;; (load "list-functions.lisp") -;; (load "reader.lisp") -;; (load "sharpsign.lisp") -;; (load "control-flow.lisp") -;; (load "types.lisp") -;; (load "numbers.lisp") -;; (load "list-functions-2.lisp") -;; (load "ffi.lisp") +(load "defun-0.lisp") +(load "list-functions.lisp") +(load "destructuring-bind.lisp") +(load "defun-1.lisp") +(load "list-functions.lisp") +(load "reader.lisp") +(load "sharpsign.lisp") +(load "control-flow.lisp") +(load "types.lisp") +(load "numbers.lisp") +(load "list-functions-2.lisp") +(load "ffi.lisp") -;; (load "Sacla/share.lisp") -;; (load "Sacla/do.lisp") +(load "Sacla/share.lisp") +(load "Sacla/do.lisp") -;; (load "evaluation.lisp") +(load "evaluation.lisp") -;; (load "Sacla/share-2.lisp") +(load "Sacla/share-2.lisp") -;; (load "Sacla/data-and-control.lisp") +(load "Sacla/data-and-control.lisp") -;; (load "array.lisp") -;; (load "Sacla/array.lisp") +(load "array.lisp") +(load "Sacla/array.lisp") -;; (load "string.lisp") -;; (load "package.lisp") +(load "string.lisp") +(load "package.lisp") (setq *system-initialised-p* t) -- cgit v1.2.3 From 315e73730a0d1e3e00d8c567866465be8914ab03 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 12:24:33 +0200 Subject: =?UTF-8?q?LLVM=20compiler=20=E2=80=94=20IF:=20For=20the=20return?= =?UTF-8?q?=20value,=20use=20alloca=20instead=20of=20phi.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- MLKLLVMCompiler.mm | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index e7dc660..c5e463c 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -710,29 +710,24 @@ static Constant BasicBlock *elseBlock = BasicBlock::Create ("if_else"); BasicBlock *joinBlock = BasicBlock::Create ("if_join"); - Value *thenValue, *elseValue; - Value *test = builder.CreateICmpNE ([_conditionForm processForLLVM], ConstantPointerNull::get (PointerTy)); + Value *value = builder.CreateAlloca (PointerTy, NULL, "if_result"); builder.CreateCondBr (test, thenBlock, elseBlock); builder.SetInsertPoint (thenBlock); - thenValue = [_consequentForm processForLLVM]; + builder.CreateStore ([_consequentForm processForLLVM], value); builder.CreateBr (joinBlock); builder.SetInsertPoint (elseBlock); function->getBasicBlockList().push_back (elseBlock); - elseValue = [_alternativeForm processForLLVM]; + builder.CreateStore ([_alternativeForm processForLLVM], value); builder.CreateBr (joinBlock); builder.SetInsertPoint (joinBlock); function->getBasicBlockList().push_back (joinBlock); - PHINode *value = builder.CreatePHI (PointerTy, "if_result"); - value->addIncoming (thenValue, thenBlock); - value->addIncoming (elseValue, elseBlock); - - return value; + return builder.CreateLoad (value); } @end -- cgit v1.2.3 From eb4cebd18d1fc9c94773ae46cf1377093955f802 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 14:04:34 +0200 Subject: Define T and NIL as global variables. --- util.lisp | 3 +++ 1 file changed, 3 insertions(+) diff --git a/util.lisp b/util.lisp index ede7eeb..b9601e4 100644 --- a/util.lisp +++ b/util.lisp @@ -22,6 +22,9 @@ otherwise unless when eq boundp)) +(setq t 't) +(setq nil ()) + (%macroset '%defmacro (%lambda args (let ((form (car args))) -- cgit v1.2.3 From ff954858e055bc58c18502eb3d0aac5ad99c1cb1 Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 14:04:58 +0200 Subject: MLKReadEvalPrintLoop: Include string.h. --- MLKReadEvalPrintLoop.m | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/MLKReadEvalPrintLoop.m b/MLKReadEvalPrintLoop.m index a23ba36..fc0d8ef 100644 --- a/MLKReadEvalPrintLoop.m +++ b/MLKReadEvalPrintLoop.m @@ -35,7 +35,8 @@ #import #endif -#import +#include +#include static int _argc; -- cgit v1.2.3 From 1e2602cbd46ab6587aa80f82661e6145e018d05f Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 14:05:58 +0200 Subject: Add a couple of disabled debugging messages. --- MLKForm.m | 1 + MLKLLVMCompiler.mm | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/MLKForm.m b/MLKForm.m index ee5139f..c8a5416 100644 --- a/MLKForm.m +++ b/MLKForm.m @@ -209,6 +209,7 @@ forCompiler:compiler]; id macrofun = [context macroForSymbol:_head]; + //NSLog (@"Expanding: %@", MLKPrintToString (_form)); id expansion = denullify ([[macrofun applyToArray: [NSArray arrayWithObjects: diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index c5e463c..cf7cf29 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -379,8 +379,12 @@ static Constant { Value *value; + //NSLog (@"Symbol: %@", MLKPrintToString (_form)); + //[_compiler insertTrace:[NSString stringWithFormat:@"Symbol: %@", _form]]; + if (![_context variableIsLexical:_form]) { + //[_compiler insertTrace:@"Dynamic."]; Value *mlkdynamiccontext = [_compiler insertClassLookup:@"MLKCons"]; Value *dynctx = [_compiler insertMethodCall:@"currentContext" onObject:mlkdynamiccontext]; @@ -398,6 +402,7 @@ static Constant } else if ([_context variableHeapAllocationForSymbol:_form]) { + //[_compiler insertTrace:@"Global."]; Value *binding = builder.CreateLoad (builder.Insert ([_context bindingCellValueForSymbol:_form])); value = [_compiler insertMethodCall:@"value" onObject:binding]; } -- cgit v1.2.3 From 054dc70426505f72a1e9856c9e48c0ae3349d68d Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Mon, 18 Aug 2008 14:06:34 +0200 Subject: =?UTF-8?q?LLVM=20compiler=20=E2=80=94=20SETQ:=20Fix=20a=20typo.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- MLKLLVMCompiler.mm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/MLKLLVMCompiler.mm b/MLKLLVMCompiler.mm index cf7cf29..aa0ab79 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -770,7 +770,7 @@ static Constant onObject:dynctx withArgumentVector:&args]; } - if ([_context variableHeapAllocationForSymbol:variable]) + else if ([_context variableHeapAllocationForSymbol:variable]) { Value *binding = builder.CreateLoad (builder.Insert ([_context bindingCellValueForSymbol:variable])); -- cgit v1.2.3