diff options
| -rw-r--r-- | MLKCons.m | 4 | ||||
| -rw-r--r-- | MLKForm.h | 32 | ||||
| -rw-r--r-- | MLKForm.m | 143 | ||||
| -rw-r--r-- | MLKInterpreter.m | 132 | ||||
| -rw-r--r-- | MLKLLVMCompiler.h | 2 | ||||
| -rw-r--r-- | MLKLLVMCompiler.mm | 286 | ||||
| -rw-r--r-- | MLKLexicalContext-MLKLLVMCompilation.h | 2 | ||||
| -rw-r--r-- | MLKLexicalContext-MLKLLVMCompilation.mm | 12 | ||||
| -rw-r--r-- | MLKLexicalContext.h | 7 | ||||
| -rw-r--r-- | MLKLexicalContext.m | 41 | ||||
| -rw-r--r-- | MLKLexicalEnvironment.m | 32 | ||||
| -rw-r--r-- | MLKPackage.m | 6 | ||||
| -rw-r--r-- | MLKReadEvalPrintLoop.m | 15 | ||||
| -rw-r--r-- | MLKRoot.m | 64 | ||||
| -rw-r--r-- | functions.h | 3 | ||||
| -rw-r--r-- | functions.m | 28 | ||||
| -rw-r--r-- | special-symbols.h | 8 | ||||
| -rw-r--r-- | util.lisp | 14 |
18 files changed, 535 insertions, 296 deletions
@@ -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]]; @@ -91,6 +91,7 @@ { id _body; NSArray *_bodyForms; + id _bodyContext; } -(void) splitDeclarationsAndBody:(id)object; @@ -133,14 +134,6 @@ @end -@interface MLKSimpleDefmacroForm : MLKDeclaringForm -{ - MLKSymbol *_lambdaListName; - MLKSymbol *_name; -} -@end - - @interface MLKEvalWhenForm : MLKBodyForm { BOOL _compileToplevel; @@ -281,22 +274,6 @@ @end -@interface MLKSetForm : MLKCompoundForm -{ - MLKForm *_variableForm; - MLKForm *_valueForm; -} -@end - - -@interface MLKFSetForm : MLKCompoundForm -{ - MLKForm *_functionNameForm; - MLKForm *_valueForm; -} -@end - - @interface MLKThrowForm : MLKCompoundForm { MLKForm *_tagForm; @@ -319,6 +296,10 @@ } +(Class) dispatchClassForObject:(id)object; + +-(id) name; +-(id) lambdaListName; +-(id) bodyForms; @end @@ -329,6 +310,9 @@ } +(Class) dispatchClassForObject:(id)object; + +-(id) name; +-(id) valueForm; @end @@ -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]; } @@ -56,7 +57,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 +90,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]; @@ -128,9 +129,7 @@ { id car = [object car]; - if (car == APPLY) return [MLKFunctionCallForm class]; - else if (car == CATCH) return [MLKCatchForm class]; - else if (car == _DEFMACRO) return [MLKSimpleDefmacroForm 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]; @@ -148,8 +147,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]; @@ -173,24 +170,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]); } } @@ -212,15 +209,16 @@ forCompiler:compiler]; id <MLKFuncallable> macrofun = [context macroForSymbol:_head]; + //NSLog (@"Expanding: %@", MLKPrintToString (_form)); id expansion = denullify ([[macrofun applyToArray: [NSArray arrayWithObjects: _form, context, nil]] objectAtIndex:0]); - return [MLKForm formWithObject:expansion - inContext:context - forCompiler:compiler]; + return LRETAIN ([MLKForm formWithObject:expansion + inContext:context + forCompiler:compiler]); } @end @@ -228,7 +226,7 @@ @implementation MLKBodyForm -(void) splitDeclarationsAndBody:(id)object { - _body = object; + LASSIGN (_body, object); } -(void) processBody:(id)object inContext:(MLKLexicalContext *)context @@ -246,6 +244,7 @@ rest = [rest cdr]; } + LASSIGN (_bodyContext, context); LASSIGN (_bodyForms, bodyForms); } @@ -333,31 +332,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 { @@ -550,7 +524,7 @@ inContext:newContext forCompiler:_compiler]; LRELEASE (self); //?FIXME - return newForm; + return LRETAIN (newForm); } @end @@ -733,16 +707,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]; } @@ -762,16 +737,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]; } @@ -788,40 +764,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 { @@ -883,6 +825,21 @@ inContext:newContext]; return self; } + +-(id) name +{ + return _name; +} + +-(id) lambdaListName +{ + return _lambdaListName; +} + +-(id) bodyForms +{ + return _bodyForms; +} @end @@ -914,6 +871,16 @@ { return [[super subforms] arrayByAddingObject:_valueForm]; } + +-(id) name +{ + return _name; +} + +-(id) valueForm +{ + return _valueForm; +} @end diff --git a/MLKInterpreter.m b/MLKInterpreter.m index 693c742..0cdf904 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" @@ -192,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; @@ -289,46 +263,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 <MLKFuncallable> 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] @@ -1059,59 +993,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; @@ -1335,7 +1216,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])]; @@ -1347,6 +1229,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 @@ -1370,6 +1257,7 @@ withEnvironment:[MLKLexicalEnvironment globalEnvironment] expandOnly:NO]; //NSLog (@"; LOAD: Top-level form evaluated."); +#endif //!USE_LLVM LRELEASE (pool); 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 4313ac9..aa0ab79 100644 --- a/MLKLLVMCompiler.mm +++ b/MLKLLVMCompiler.mm @@ -16,10 +16,14 @@ * along with this program. If not, see <http://www.gnu.org/licenses/>. */ +#import "MLKDynamicContext.h" #import "MLKLLVMCompiler.h" +#import "MLKPackage.h" #import "globals.h" +#import "util.h" #import <Foundation/NSArray.h> +#import <Foundation/NSAutoreleasePool.h> #import <Foundation/NSEnumerator.h> #import <Foundation/NSString.h> @@ -100,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<const Type*> noargs (0, Type::VoidTy); @@ -112,27 +119,33 @@ 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); fpm->run (*function); + //function->dump(); + // JIT-compile. fn = (id (*)()) execution_engine->getPointerToFunction (function); - module->dump(); - NSLog (@"%p", fn); + //module->dump(); + //NSLog (@"%p", fn); + + [pool release]; + //NSLog (@"Code compiled."); // Execute. lambdaForm = fn(); - NSLog (@"Closure built."); + //NSLog (@"Closure built."); return lambdaForm; } @@ -150,7 +163,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 @@ -314,10 +332,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])) { @@ -364,9 +379,31 @@ static Constant { Value *value; - if ([_context variableHeapAllocationForSymbol:_form]) + //NSLog (@"Symbol: %@", MLKPrintToString (_form)); + //[_compiler insertTrace:[NSString stringWithFormat:@"Symbol: %@", _form]]; + + if (![_context variableIsLexical:_form]) { - Value *binding = builder.CreateLoad ([_context bindingValueForSymbol:_form]); + //[_compiler insertTrace:@"Dynamic."]; + 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<Value *> args (1, symbolV); + value = [_compiler insertMethodCall:@"valueForSymbol:" + onObject:dynctx + withArgumentVector:&args]; + } + else if ([_context variableHeapAllocationForSymbol:_form]) + { + //[_compiler insertTrace:@"Global."]; + Value *binding = builder.CreateLoad (builder.Insert ([_context bindingCellValueForSymbol:_form])); value = [_compiler insertMethodCall:@"value" onObject:binding]; } else @@ -383,28 +420,67 @@ 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<Value *> 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<const Type *> 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<Value *> args; - args.push_back (closureDataPtr); - while ((form = [e nextObject])) { 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), @@ -534,7 +610,7 @@ static Constant builder.CreateRet (value); - function->dump(); + //function->dump(); //NSLog (@"Verify..."); verifyFunction (*function); //NSLog (@"Optimise..."); @@ -544,7 +620,7 @@ static Constant // the function. execution_engine->getPointerToFunction (function); //NSLog (@"Done."); - function->dump(); + //function->dump(); //NSLog (@"Function built."); builder.SetInsertPoint (outerBlock); @@ -569,3 +645,165 @@ 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 + + +@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 *test = builder.CreateICmpNE ([_conditionForm processForLLVM], + ConstantPointerNull::get (PointerTy)); + Value *value = builder.CreateAlloca (PointerTy, NULL, "if_result"); + builder.CreateCondBr (test, thenBlock, elseBlock); + + builder.SetInsertPoint (thenBlock); + builder.CreateStore ([_consequentForm processForLLVM], value); + builder.CreateBr (joinBlock); + + builder.SetInsertPoint (elseBlock); + function->getBasicBlockList().push_back (elseBlock); + builder.CreateStore ([_alternativeForm processForLLVM], value); + builder.CreateBr (joinBlock); + + builder.SetInsertPoint (joinBlock); + function->getBasicBlockList().push_back (joinBlock); + + return builder.CreateLoad (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 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<Value *> args; + args.push_back (value); + args.push_back (symbolV); + [_compiler insertMethodCall:@"setValue:forSymbol:" + onObject:dynctx + withArgumentVector:&args]; + } + else if ([_context variableHeapAllocationForSymbol:variable]) + { + Value *binding = builder.CreateLoad (builder.Insert ([_context + bindingCellValueForSymbol:variable])); + std::vector<Value *> args (1, value); + + [_compiler insertVoidMethodCall:@"setValue:" + onObject:binding + withArgumentVector:&args]; + } + else + { + builder.CreateStore (value, [_context valueValueForSymbol:variable]); + } + } + + 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 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 1eaa51c..3f820a8 100644 --- a/MLKLexicalContext.m +++ b/MLKLexicalContext.m @@ -37,6 +37,8 @@ #import "runtime-compatibility.h" #import "util.h" +#include <stdlib.h> + #define MAKE_ENVIRONMENT(variable, parent, parent_member) \ [[MLKEnvironment alloc] \ @@ -196,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]) @@ -209,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]) @@ -220,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]) @@ -399,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 diff --git a/MLKPackage.m b/MLKPackage.m index acaf6db..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"]]; @@ -101,15 +100,14 @@ 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"]]; - [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"]]; @@ -155,6 +153,8 @@ 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:@"APPLY"]]; [sys export:[sys intern:@"OBJC-CLASS-OF"]]; [sys export:[sys intern:@"OBJC-SUBCLASSP"]]; diff --git a/MLKReadEvalPrintLoop.m b/MLKReadEvalPrintLoop.m index 2ddc5d7..fc0d8ef 100644 --- a/MLKReadEvalPrintLoop.m +++ b/MLKReadEvalPrintLoop.m @@ -31,7 +31,12 @@ #import <Foundation/NSNull.h> #import <Foundation/NSString.h> -#import <histedit.h> +#ifdef GNUSTEP +#import <Foundation/NSDebug.h> +#endif + +#include <histedit.h> +#include <string.h> static int _argc; @@ -132,7 +137,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 +161,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 +169,7 @@ static const char *prompt (EditLine *e) { [[localException reason] UTF8String]); } NS_ENDHANDLER; +#endif LRELEASE (pool); } @@ -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); @@ -707,12 +711,66 @@ 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 + ++(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); +} + ++(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); +} + ++(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/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 <Foundation/NSString.h> #include <stdint.h> @@ -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 <Foundation/NSArray.h> #import <Foundation/NSException.h> #import <Foundation/NSString.h> @@ -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; } diff --git a/special-symbols.h b/special-symbols.h index fa68ba7..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; @@ -44,14 +43,11 @@ 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; static MLKSymbol *VALUES; -static MLKSymbol *_DEFMACRO; static MLKSymbol *_FOREIGN_LAMBDA; static MLKSymbol *_LAMBDA; static MLKSymbol *_LOOP; @@ -87,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"]; @@ -95,14 +90,11 @@ 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"]; 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*"]; @@ -22,6 +22,20 @@ otherwise unless when eq boundp)) +(setq t 't) +(setq nil ()) + +(%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)))) |