From 63df59e7ab921baff00e47e915b4df1c441b2381 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 29 Nov 2011 19:19:54 +0000 Subject: * boot/tokens.boot (absKind, absParms, absBody): New selectors. * interp/compiler.boot (canReturn): Handle %lambda forms. (compUnnamedMapping): Generate %lambda forms. Don't optimize them yet. * interp/g-opt.boot: %lambda forms are side-effect free. * interp/lisp-backend.boot: Translate them. --- src/ChangeLog | 9 +++++++++ src/boot/strap/tokens.clisp | 11 ++++++----- src/boot/strap/translator.clisp | 2 +- src/boot/tokens.boot | 3 +++ src/interp/compiler.boot | 5 ++--- src/interp/g-opt.boot | 8 ++++---- src/interp/g-util.boot | 2 +- src/interp/lisp-backend.boot | 2 ++ src/interp/nruncomp.boot | 3 +-- 9 files changed, 29 insertions(+), 16 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index ae9597dd..f033da2f 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,12 @@ +2011-11-29 Gabriel Dos Reis + + * boot/tokens.boot (absKind, absParms, absBody): New selectors. + * interp/compiler.boot (canReturn): Handle %lambda forms. + (compUnnamedMapping): Generate %lambda forms. Don't optimize them + yet. + * interp/g-opt.boot: %lambda forms are side-effect free. + * interp/lisp-backend.boot: Translate them. + 2011-11-29 Gabriel Dos Reis * interp/g-opt.boot (isSimpleForm): Remove as unused. diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index ea0dabcf..ceecbce5 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -232,11 +232,12 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))) (LET ((|bfVar#1| - (LIST (LIST '|setName| 0) (LIST '|setLabel| 1) (LIST '|setLevel| 2) - (LIST '|setType| 3) (LIST '|setVar| 4) (LIST '|setLeaf| 5) - (LIST '|setDef| 6) (LIST '|aGeneral| 4) (LIST '|aMode| 1) - (LIST '|aModeSet| 3) (LIST '|aTree| 0) (LIST '|aValue| 2) - (LIST '|args| 'CDR) (LIST '|attributes| 'CADDR) + (LIST (LIST '|absKind| 'CAR) (LIST '|absParms| 'CADR) + (LIST '|absBody| 'CADDR) (LIST '|setName| 0) (LIST '|setLabel| 1) + (LIST '|setLevel| 2) (LIST '|setType| 3) (LIST '|setVar| 4) + (LIST '|setLeaf| 5) (LIST '|setDef| 6) (LIST '|aGeneral| 4) + (LIST '|aMode| 1) (LIST '|aModeSet| 3) (LIST '|aTree| 0) + (LIST '|aValue| 2) (LIST '|args| 'CDR) (LIST '|attributes| 'CADDR) (LIST '|cacheCount| 'CADDDDR) (LIST '|cacheName| 'CADR) (LIST '|cacheReset| 'CADDDR) (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR) (LIST '|expr| 'CAR) (LIST 'CAR 'CAR) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 2f87cc64..9abbe2ca 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -93,7 +93,7 @@ (|reallyPrettyPrint| (LIST 'PROCLAIM (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|))) |stream|)) -(DEFUN |AxiomCore|::|%sysInit| () +(DEFUN |%sysInit| () (PROGN (SETQ *LOAD-VERBOSE* NIL) (COND diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot index 663f1301..b45cb669 100644 --- a/src/boot/tokens.boot +++ b/src/boot/tokens.boot @@ -340,6 +340,9 @@ for i in [ _ for i in [ _ + ["absKind", "CAR"] ,_ + ["absParms", "CADR"] ,_ + ["absBody", "CADDR"] ,_ ["setName", 0] , _ ["setLabel", 1] , _ ["setLevel", 2] , _ diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 0254f3db..dea05b3d 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1379,7 +1379,7 @@ compIf(["IF",a,b,c],m,E) == canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends expr isnt [.,:.] => ValueFlag and level=exitCount op := expr.op - op in '(QUOTE CLOSEDFN) => ValueFlag and level=exitCount + op in '(QUOTE CLOSEDFN %lambda) => ValueFlag and level=exitCount op is "TAGGEDexit" => expr is [.,count,data] => canReturn(data.expr,level,count,count=level) level=exitCount and not ValueFlag => nil @@ -2684,8 +2684,7 @@ compUnnamedMapping(parms,source,target,body,env) == [.,.,env] := compMakeDeclaration(p,s,env) env := giveVariableSomeValue(p,get(p,'mode,env),env) T := comp(body,target,env) or return nil - [.,fun] := optimizeFunctionDef [nil,["LAMBDA",parms,T.expr]] - fun := finishLambdaExpression(fun,env) + fun := ['%closure,['%lambda,[:parms,'$],T.expr],'$] [fun,["Mapping",T.mode,:source],savedEnv] gatherParameterList vars == main(vars,nil,nil) where diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index a859c67a..c92e326e 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -95,7 +95,7 @@ changeVariableDefinitionToStore(form,vars) == changeVariableDefinitionToStore(third form,vars') vars abstractionOperator? form.op => - changeVariableDefinitionToStore(third form,[:second form,:vars]) + changeVariableDefinitionToStore(form.absBody,[:form.absParms,:vars]) vars for x in form repeat vars := changeVariableDefinitionToStore(x,vars) @@ -180,8 +180,8 @@ simplifyVMForm x == atomic? x => x x.op is 'CLOSEDFN => x x.op isnt [.,:.] => - x is [op,vars,body] and abstractionOperator? op => - third(x) := simplifyVMForm body + symbol? x.op and abstractionOperator? x.op => + x.absBody := simplifyVMForm x.absBody x if x.op is 'IF then resetTo(x,optIF2COND x) @@ -455,7 +455,7 @@ $VMsideEffectFreeOperators == %bitveccopy %bitvecconc %bitveclength %bitvecref %bitveceq %bitveclt %before? %equal %sptreq %ident? %property %tref %writeString %writeNewline %writeLine - %void %retract %pullback) + %void %retract %pullback %lambda %closure) ++ List of simple VM operators $simpleVMoperators == diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index d826627c..18ada7f8 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -86,7 +86,7 @@ macro builtinConstructor? s == --% $AbstractionOperator == - '(LAM ILAM SLAM XLAM SPADSLAM LAMBDA) + '(LAM ILAM SLAM XLAM SPADSLAM LAMBDA %lambda) ++ Return true if the symbol 's' is used in the form 'x'. usedSymbol?(s,x) == diff --git a/src/interp/lisp-backend.boot b/src/interp/lisp-backend.boot index 17efec64..3b41d361 100644 --- a/src/interp/lisp-backend.boot +++ b/src/interp/lisp-backend.boot @@ -629,8 +629,10 @@ for x in [ ['%lam, :'LAMBDA], ['%leave, :'RETURN], ['%otherwise,:'T], + ['%closure, :'CONS], ['%funcall, :'FUNCALL], ['%function, :'FUNCTION], + ['%lambda, :'LAMBDA], ['%when, :'COND], -- I/O stream functions diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 2fe210e9..29a36988 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -666,8 +666,7 @@ NRTputInHead(db,bod) == bod is ['%when,:clauses] => for cc in clauses repeat NRTputInTail(db,cc) bod - bod is ['QUOTE,:.] => bod - bod is ["CLOSEDFN",:.] => bod + bod.op in '(QUOTE CLOSEDFN) => bod NRTputInHead(db,first bod) NRTputInTail(db,rest bod) bod -- cgit v1.2.3