diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 54 | ||||
| -rw-r--r-- | src/interp/define.boot | 22 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 64 | ||||
| -rw-r--r-- | src/interp/lisp-backend.boot | 6 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 4 |
5 files changed, 45 insertions, 105 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 132ab160..042421ec 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -188,7 +188,8 @@ comp3(x,m,$e) == nil x isnt [.,:.] => compAtom(x,m,e) op:= x.op - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u + ident? op and getXmode(op,e) is ["Mapping",:ml] + and (T := applyMapping(x,m,e,ml)) => T op is ":" => compColon(x,m,e) op is "::" => compCoerce(x,m,e) not $insideCompTypeOf and stringPrefix?('"TypeOf",PNAME op) => @@ -236,33 +237,10 @@ applyMapping([op,:argl],m,e,ml) == emitLocalCallInsn(op,argl',e) -- Compiler synthetized operators are inline. u ~= nil and u.expr is ["XLAM",:.] => ['%call,u.expr,:argl'] - ['%call,['applyFun,op],:argl'] + ['%apply,op,:argl'] pairlis := pairList($FormalMapVariableList,argl') convert([form,applySubst(pairlis,first ml),e],m) --- This version tends to give problems with #1 and categories --- applyMapping([op,:argl],m,e,ml) == --- #argl~=#ml-1 => nil --- mappingHasCategoryTarget := --- isCategoryForm(first ml,e) => --is op a functor? --- form:= [op,:argl'] --- pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] --- ml:= applySubst(pairlis,ml) --- true --- false --- argl':= --- [T.expr for x in argl for m' in rest ml] where --- T() == [.,.,e]:= comp(x,m',e) or return "failed" --- if argl'="failed" then return nil --- mappingHasCategoryTarget => convert([form,first ml,e],m) --- form:= --- not symbolMember?(op,$formalArgList) and op isnt [.,:.] => --- [op',:argl',"$"] where --- op':= makeSymbol strconc(STRINGIMAGE $prefix,";",STRINGIMAGE op) --- ['%call,["applyFun",op],:argl'] --- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] --- convert([form,applySubst(pairlis,first ml),e],m) - hasFormalMapVariable(x, vl) == $formalMapVariables: local := vl null vl => false @@ -356,10 +334,10 @@ compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) == if string? x then x := makeSymbol x for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat [.,.,e]:= compMakeDeclaration(v,m,e) - (vl ~= nil) and not hasFormalMapVariable(x, vl) => return + (vl ~= nil) and not hasFormalMapVariable(x, vl) => [u,.,.] := comp([x,:vl],m',e) or return nil extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return + null vl and (t := comp([x], m', e)) => [u,.,.] := t extractCodeAndConstructTriple(u, m, oldE) [u,.,.]:= comp(x,m',e) or return nil @@ -370,6 +348,7 @@ extractCodeAndConstructTriple(u, m, oldE) == u is ['%call,fn,:.] => if fn is ["applyFun",a] then fn := a [fn,m,oldE] + u is ['%apply,op,:.] => [op,m,oldE] [op,:.,env] := u [["CONS",["function",op],env],m,oldE] @@ -694,11 +673,13 @@ compApplication(op,argl,m,T) == for x in argl for m in argml] argTl = "failed" => nil form:= - T.expr isnt [.,:.] and + args := [a.expr for a in argTl] + ident? T.expr and not (symbolMember?(op,$formalArgList) or symbolMember?(T.expr,$formalArgList)) and null get(T.expr,"value",e) => - emitLocalCallInsn(T.expr,[a.expr for a in argTl],e) - ['%call, ['applyFun, T.expr], :[a.expr for a in argTl]] + emitLocalCallInsn(T.expr,args,e) + ident? T.expr => ['%apply,T.expr,:args] + ['%call,['applyFun,T.expr],:args] coerce([form, retm, e],resolve(retm,m)) op is 'elt => nil eltForm := ['elt, op, :argl] @@ -851,6 +832,9 @@ setqSingle(id,val,m,E) == if isDomainForm(val,e') then if isDomainInScope(id,e') then stackWarning('"domain valued variable %1b has been reassigned within its scope",[id]) + -- single domains have constant values in their scopes, we might just + -- as well take advantage of that at compile-time where appropriate. + e' := put(id,'%macro,val,e') e':= augModemapsFromDomain1(id,val,e') --all we do now is to allocate a slot number for lhs --e.g. the %LET form below will be changed by putInLocalDomainReferences @@ -1714,10 +1698,10 @@ coerceHard(T,m) == $e: local:= T.env m':= T.mode string? m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and + modeEqual(m',m) or ident? m' and + (get(m',"value",$e) is [m'',:.] or getXmode(m',$e) is ["Mapping",m'']) and + modeEqual(m'',m) or ident? m and + (get(m,"value",$e) is [m'',:.] or getXmode(m,$e) is ["Mapping",m'']) and modeEqual(m'',m') => [T.expr,m,T.env] string? T.expr and T.expr=m => [T.expr,m,$e] isCategoryForm(m,$e) => @@ -1778,7 +1762,7 @@ autoCoerceByModemap: (%Maybe %Triple,%Mode) -> %Maybe %Triple compCoerce(["::",x,m'],m,e) == e:= addDomain(m',e) T:= compCoerce1(x,m',e) => coerce(T,m) - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => + ident? m' and getXmode(m',e) is ["Mapping",["UnionCategory",:l]] => T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil coerce([T.expr,m',T.env],m) diff --git a/src/interp/define.boot b/src/interp/define.boot index 81a9e6d9..96db10dc 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -514,6 +514,12 @@ hasDefaultPackage catname == constructor? defname => defname nil +++ Like getmode, except that if the mode is local variable with +++ defined value, we want that value instead. +getXmode(x,e) == + m := getmode(x,e) or return nil + ident? m and get(m,'%macro,e) or m + --======================================================================= -- Compute the lookup function (complete or incomplete) @@ -522,7 +528,7 @@ NRTgetLookupFunction(domform,exCategory,addForm,env) == $why: local := nil domform := applySubst($pairlis,domform) addForm isnt [.,:.] => - IDENTP addForm and (m := getmode(addForm,env)) ~= nil + ident? addForm and (m := getmode(addForm,env)) ~= nil and isCategoryForm(m,env) and extendsCategory(domform,exCategory,applySubst($pairlis,m),env) => 'lookupIncomplete @@ -1503,7 +1509,7 @@ displayMissingFunctions() == loc := nil -- list of local operation signatures exp := nil -- list of exported operation signatures for [[op,sig,:.],:pred] in $CheckVectorList | not pred repeat - not symbolMember?(op,$formalArgList) and getmode(op,$e) is ['Mapping,:.] => + not symbolMember?(op,$formalArgList) and getXmode(op,$e) is ['Mapping,:.] => loc := [[op,sig],:loc] exp := [[op,sig],:exp] if loc then @@ -1745,7 +1751,7 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], localOrExported := not symbolMember?($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local + getXmode($op,e) is ['Mapping,:.] => 'local 'exported --6a skip if compiling only certain items but not this one @@ -1780,7 +1786,7 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], [fun,['Mapping,:signature'],$e] getSignatureFromMode(form,e) == - getmode(opOf form,e) is ['Mapping,:signature] => + getXmode(opOf form,e) is ['Mapping,:signature] => #form~=#signature => stackAndThrow ["Wrong number of arguments: ",form] applySubst(pairList($FormalMapVariableList,form.args),signature) @@ -1814,7 +1820,7 @@ addDomain(domain,e) == addNewDomain(domain,e) (name:= first domain)='Category => e domainMember(domain,getDomainsInScope e) => e - getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> + getXmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e) => addNewDomain(domain,e) -- constructor? test needed for domains compiled with $bootStrapMode=true isDomainForm(domain,e) => addNewDomain(domain,e) @@ -1887,7 +1893,7 @@ getSignature(op,argModeList,$e) == for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ and sig.source = argModeList and knownInfo(pred,$e)]) => first sigl null sigl => - (u:= getmode(op,$e)) is ['Mapping,:sig] => sig + (u:= getXmode(op,$e)) is ['Mapping,:sig] => sig SAY '"************* USER ERROR **********" SAY("available signatures for ",op,": ") if null mmList @@ -1968,7 +1974,7 @@ compile u == where isLocalFunction op == null symbolMember?(op,$formalArgList) and - getmode(op,$e) is ['Mapping,:.] + getXmode(op,$e) is ['Mapping,:.] u:= [op',lamExpr] -- If just updating certain functions, check for previous existence. -- Deduce old sequence number and use it (items have been skipped). @@ -2368,7 +2374,7 @@ compJoin(["Join",:argl],m,e) == x is ["DomainSubstitutionMacro",pl,body] => (parameters:= union(pl,parameters); body) x is ["mkCategory",:.] => x - x isnt [.,:.] and getmode(x,e) = $Category => x + ident? x and getXmode(x,e) = $Category => x stackSemanticError(["invalid argument to Join: ",x],nil) x T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 287e5f7d..05860159 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -280,7 +280,8 @@ doInlineCall(args,parms,body) == for arg in args for parm in parms repeat g := gensym() tmps := [g,:tmps] - sideEffectFree? arg or numOfOccurencesOf(parm,body) = 1 => + n := numOfOccurencesOf(parm,body) + atomic? arg or (sideEffectFree? arg and n < 2) or n = 1 => subst := [[g,:arg],:subst] inits := [[g,arg],:inits] -- 4. Alpha-rename the body and substitute simple expression arguments. @@ -417,8 +418,7 @@ optSuchthat [.,:u] == ["SUCHTHAT",:u] ++ List of VM side effect free operators. $VMsideEffectFreeOperators == - '(FUNCALL %apply - SPADfirst ASH FLOAT_-RADIX FLOAT FLOAT_-SIGN + '(SPADfirst ASH FLOAT FLOAT_-SIGN %funcall %nothing %when %false %true %otherwise %2bit %2bool %and %or %not %peq %ieq %ilt %ile %igt %ige %head %tail %integer? %beq %blt %ble %bgt %bge %bitand %bitior %bitxor %bitnot %bcompl @@ -452,8 +452,8 @@ $VMsideEffectFreeOperators == ++ List of simple VM operators $simpleVMoperators == append($VMsideEffectFreeOperators, - ['SPADCALL,'%gensym, '%lreverse!, - '%strstc,"MAKE-FULL-CVEC"]) + ['SPADCALL,'%apply, '%gensym, '%lreverse!, + '%strstc]) ++ Return true if the `form' is semi-simple with respect to ++ to the list of operators `ops'. @@ -528,7 +528,7 @@ dependentVars expr == main(expr,nil) where vars := main(y,vars) vars -++ Subroutine of optLET and optBind. Return true if the variable `var' locally +++ Subroutine of optBind. Return true if the variable `var' locally ++ defined in a binding form can be safely replaced by its initalization ++ `expr' in the `body' of the binding form. canInlineVarDefinition(var,expr,body) == @@ -559,57 +559,6 @@ canInlineVarDefinition(var,expr,body) == ++ This transformation will probably be more effective when all ++ type informations are still around. Which is why we should ++ have a type directed compilation throughout. -optLET u == - -- Hands off non-simple cases. - u isnt ["LET",inits,body] => u - -- Inline functionally used local variables with their initializers. - inits := [:newInit for (init := [var,expr]) in inits] where - newInit() == - canInlineVarDefinition(var,expr,body) => - body := substitute(expr,var,body) - nil -- remove this initialization - [init] -- otherwwise keep it. - null inits => body - u.rest.first := inits - u.rest.rest.first := body - -- Avoid initialization forms that may not be floatable. - not(and/[isFloatableVMForm init for [.,init] in inits]) => u - -- Identity function. - inits is [[=body,init]] => init - -- Handle only most trivial operators. - body isnt [op,:args] => u - -- Well, with case-patterns, it is beneficial to try a bit harder - -- with conditional forms. - op is '%when => - continue := true -- shall be continue let-inlining? - -- Since we do a single pass, we can't reuse the inits list - -- as we may find later that we can't really inline into - -- all forms due to excessive conversatism. So we build a - -- substitution list ahead of time. - substPairs := [[var,:init] for [var,init] in inits] - for clauses in tails args while continue repeat - clause := first clauses - -- we do not attempt more complicated clauses yet. - clause isnt [test,stmt] => continue := false - -- Stop inlining at least one test is not simple - not isSimpleVMForm test => continue := false - clause.first := applySubst(substPairs,test) - isSimpleVMForm stmt => - clause.rest.first := applySubst(substPairs,stmt) - continue := false - continue => body - u - not symbolMember?(op,$simpleVMoperators) => u - not(and/[atomic? arg for arg in args]) => u - -- Inline only if all parameters are used. Get cute later. - not(and/[symbolMember?(x,args) for [x,.] in inits]) => u - -- Munge inits into list of dotted-pairs. Lovely Lisp. - for defs in tails inits repeat - def := first defs - def isnt [.,:.] => systemErrorHere ["optLET",def] -- cannot happen - def.rest := second def - applySubst(inits,body) - optBind form == form isnt ['%bind,inits,.] => form -- accept only simple bodies ok := true @@ -862,7 +811,6 @@ optIquo(x is ['%iquo,a,b]) == for x in '((%call optCall) _ (SEQ optSEQ)_ - (LET optLET)_ (%bind optBind)_ (%try optTry)_ (%not optNot)_ diff --git a/src/interp/lisp-backend.boot b/src/interp/lisp-backend.boot index 6354a5cf..79200c61 100644 --- a/src/interp/lisp-backend.boot +++ b/src/interp/lisp-backend.boot @@ -461,6 +461,9 @@ expandTry ['%try,expr,handlers,cleanup] == cleanup = nil => tryBlock ['UNWIND_-PROTECT,tryBlock,:expandToVMForm rest cleanup] +expandApply ['%apply,op,:args] == + ['SPADCALL,:args,op] + ++ Opcodes with direct mapping to target operations. for x in [ -- Boolean constants @@ -701,7 +704,8 @@ for x in [ ['%store, :function expandStore], ['%dynval, :function expandDynval], ['%throw, :function expandThrow], - ['%try, :function expandTry] + ['%try, :function expandTry], + ['%apply, :function expandApply] ] repeat property(first x,'%Expander) := rest x ++ Return the expander of a middle-end opcode, or nil if there is none. diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 4d7d0d7c..0bf11904 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -734,9 +734,7 @@ isFunctor x == builtinFunctorName? op => true getConstructorKindFromDB op in '(domain package) u := get(op,'isFunctor,$CategoryFrame) => u - op in '(SubDomain Union Record Enumeration) => true - --FIXME: above should use builtinFunctionName?. Change when - --FIXME: Mapping acquire first class functorship. + builtinFunctorName? op => true kind := getConstructorKindFromDB op kind = nil or kind = 'category => false updateCategoryFrameForConstructor op |