diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/c-util.boot | 4 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 4 | ||||
| -rw-r--r-- | src/interp/define.boot | 129 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 3 | ||||
| -rw-r--r-- | src/interp/wi2.boot | 3 |
5 files changed, 81 insertions, 62 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index c7274eb8..bec24a42 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -1005,6 +1005,10 @@ replaceSimpleFunctions form == NBUTLAST form -- 2.2. the substitution case. fun' is ["XLAM",parms,body] => + -- Inline almost constant functions. + null parms => body + -- Identity function toos. + parms is [=body] => first args -- conservatively approximate eager semantics and/[isAtomicForm first as for as in tails args] => -- alpha rename before substitution. diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 49d99f9a..6885ba74 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -220,12 +220,14 @@ applyMapping([op,:argl],m,e,ml) == T() == [.,.,e]:= comp(x,m',e) or return "failed" if argl'="failed" then return nil form:= - atom op and not(op in $formalArgList) and not get(op,"value",e) => + atom op and not(op in $formalArgList) and null (u := get(op,"value",e)) => nprefix := $prefix or -- following needed for referencing local funs at capsule level getAbbreviation($op,#rest $form) [op',:argl',"$"] where op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + -- Compiler synthetized operators are inline. + u ^= nil and u.expr is ["XLAM",:.] => ["call",u.expr,:argl'] ['call,['applyFun,op],:argl'] pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] convert([form,SUBLIS(pairlis,first ml),e],m) diff --git a/src/interp/define.boot b/src/interp/define.boot index 06b181a9..5145d76b 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -62,9 +62,6 @@ $mutableDomain := false ++ when non nil, holds the declaration number of a function in a capsule. $suffix := nil --- ??? turns off buggy code -$NRTopt := false - $doNotCompileJustPrint := false ++ stack of pending capsule function definitions. @@ -76,7 +73,6 @@ $functorStats := nil $lisplibCategory := nil $lisplibAncestors := nil $lisplibAbbreviation := nil -$LocalDomainAlist := [] $CheckVectorList := [] $setelt := nil $pairlis := [] @@ -169,45 +165,72 @@ compDefine(form,m,e) == $macroIfTrue: local := false compDefine1(form,m,e) -++ We are about to process the body of a capsule. If the capsule defines -++ `Rep' as a constant, then implicitly insert the view morphisms +++ Activate synthetized pair concretization and abstraction +++ view morphisms for domains. +insertViewMorphisms: (%Mode,$Env) -> %Env +insertViewMorphisms(t,e) == + $useRepresentationHack => e + g := GENSYM() + repType := ["Mapping",t,"$"] + perType := ["Mapping","$",t] + e := put("rep","value",[["XLAM",[g],g],repType,nil],e) + put("per","value",[["XLAM",[g],g],perType,nil],e) + +++ We are about to process the body of a capsule. Check the form of +++ `Rep' definition, and whether it is appropriate to activate the +++ implicitly generated morphisms ++ per: Rep -> % ++ rep: % -> Rep -++ as local functions. Note that we do not declare them as macros. -maybeInsertViewMorphisms: %Form -> %Form -maybeInsertViewMorphisms body == +++ as local inline functions. +checkRepresentation: %Form -> %Form +checkRepresentation body == domainRep := nil - before := nil - - while null domainRep for [stmt,:after] in tails body repeat - stmt isnt ["DEF",["Rep",:args],sig,nils,domainRep] => - before := [stmt,:before] - if args then - userError [:bright '"Rep",'"cannot take arguments"] - if first sig then - userError [:bright '"Rep", "cannot have type sepcification"] - - null domainRep => body - -- Make sure we don't implicitly convert from `Rep' to `%'. - $useRepresentationHack := false - -- Reject user-defined view morphisms - for stmt in after repeat - stmt is ["DEF",["rep",:.],:.] - or stmt is ["DEF",["per",:.],:.] => - -- ??? We may actually want to stop processing now. - stackSemanticError(['"Cannot define",:bright "per"],nil) - - -- OK, insert synthetized view morphisms - g := GENSYM() - repMorphism := ["DEF",["rep",g],[domainRep,"$"],[nil,nil], - ["pretend",g,domainRep]] - perMorphism := ["DEF",["per",g],["$",domainRep],[nil,nil], - ["pretend",g,"$"]] + hasAssignRep := false -- assume code does not assign to Rep. + viewFuns := nil + + null body => body -- Don't be too hard on nothing. - -- Trick the rest of the compiler into believing that - -- that `Rep' was defined the old way, for the purpose of lookup. - [:reverse before, ["%LET","Rep",domainRep], - :[repMorphism,perMorphism],:after] + -- Locate possible Rep definition + for [stmt,:.] in tails body repeat + stmt is ["%LET","Rep",.] => + domainRep ^= nil => + stackAndThrow('"You cannot assign to constant domain %1b",["Rep"]) + return hasAssignRep := true + stmt is ["MDEF",["Rep",:.],:.] => + stackWarning('"Consider using == definition for %1b",["Rep"]) + return hasAssignRep := true + stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] => + checkRepresentation l + $useRepresentationHack => return hasAssignRep := true + stmt isnt ["DEF",[op,:args],sig,.,val] => nil -- skip for now. + op in '(rep per) => + domainRep ^= nil => + stackAndThrow('"You cannot define implicitly generated %1b",[op]) + viewFuns := [op,:viewFuns] + op ^= "Rep" => nil -- we are only interested in Rep definition + domainRep := val + viewFuns ^= nil => + stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns]) + -- A package has no "%". + $functorKind = "package" => + stackAndThrow('"You cannot define %1b in a package",["Rep"]) + -- It is a mistake to define Rep in category defaults + $insideCategoryPackageIfTrue => + stackAndThrow('"You cannot define %1b in category defaults",["Rep"]) + if args ^= nil then + stackAndThrow('"%1b does take arguments",["Rep"]) + if first sig ^= nil then + stackAndThrow('"You cannot specify type for %1b",["Rep"]) + -- Now, trick the rest of the compiler into believing that + -- `Rep' was defined the Old Way, for lookup purpose. + rplac(first stmt,"%LET") + rplac(rest stmt,["Rep",domainRep]) + $useRepresentationHack := false -- Don't confuse `Rep' and `%'. + + -- Shall we perform the dirty tricks? + if hasAssignRep then + $useRepresentationHack := true + body compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple @@ -556,7 +579,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], $functorTarget: local := nil $Representation: local := nil --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local := [] --set in doIt, accessed in genDeltaEntry $functorForm: local := nil $functorLocalParameters: local := nil SETQ($myFunctorBody, body) @@ -581,6 +603,9 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], modemap2Signature getModemap($form,$e) target:= first signature' $functorTarget:= target + $functorKind: local := + $functorTarget is ["CATEGORY",key,:.] => key + "domain" $e:= giveFormalParametersValues(argl,$e) [ds,.,$e]:= compMakeCategoryObject(target,$e) or return stackAndThrow('" cannot produce category object: %1pb",[target]) @@ -610,20 +635,8 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], -- generate slots for arguments first, then for $NRTaddForm in compAdd for x in argl repeat NRTgetLocalIndex x [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD if not $insideCategoryPackageIfTrue then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [["%LET",'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) + $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) $signature:= signature' parSignature:= SUBLIS($pairlis,signature') parForm:= SUBLIS($pairlis,form) @@ -673,8 +686,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], $insideFunctorIfTrue:= false if $LISPLIB then $lisplibKind:= -------->This next line prohibits changing the KIND once given ---------kk:=getConstructorKindFromDB $op => kk $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package 'domain $lisplibForm:= form @@ -1409,7 +1420,7 @@ compCapsule(['CAPSULE,:itemList],m,e) == $insideExpressionIfTrue: local:= false $useRepresentationHack := true clearCapsuleFunctionTable() - compCapsuleInner(maybeInsertViewMorphisms itemList,m,addDomain('_$,e)) + compCapsuleInner(checkRepresentation itemList,m,addDomain('_$,e)) compSubDomain(["SubDomain",domainForm,predicate],m,e) == $addFormLhs: local:= domainForm @@ -1500,10 +1511,8 @@ doIt(item,$predl) == if lhs="Rep" then $Representation:= (get("Rep",'value,$e)).expr --$Representation bound by compDefineFunctor, used in compNoStacking - if $NRTopt = true - then NRTgetLocalIndex $Representation - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist] + -- Activate view morphisms if appropriate + $e := insertViewMorphisms($Representation,$e) code is ["%LET",:.] => RPLACA(item,"setShellEntry") rhsCode := rhs' diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 52f54d3f..f19a4d69 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -381,7 +381,8 @@ optEQ u == $simpleVMoperators == '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND - QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP) + SPADfirst QVELT _+ _- _* _< _= + QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP) isSimpleVMForm form == isAtomicForm form => true diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index cc1d843b..8b3967f5 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -36,6 +36,9 @@ import macros import define namespace BOOT +-- ??? turns off buggy code +$NRTopt := false + compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == ['DEF,form,signature,$functorSpecialCases,body] := df signature := markKillAll signature |