diff options
Diffstat (limited to 'src/interp/compiler.boot')
| -rw-r--r-- | src/interp/compiler.boot | 301 |
1 files changed, 270 insertions, 31 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 79b5d862..4a3c4ca4 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -38,6 +38,54 @@ import modemap import define import iterator namespace BOOT +module compiler where + coerce: (%Triple,%Mode) -> %Maybe %Triple + convert: (%Triple,%Mode) -> %Maybe %Triple + comp: (%Form,%Mode,%Env) -> %Maybe %Triple + compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple + compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple + checkCallingConvention: (%List,%Short) -> %SimpleArray %Short + + +--% +compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple +compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple +compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple +comp2: (%Form,%Mode,%Env) -> %Maybe %Triple +comp3: (%Form,%Mode,%Env) -> %Maybe %Triple +compExpression: (%Form,%Mode,%Env) -> %Maybe %Triple +compAtom: (%Form,%Mode,%Env) -> %Maybe %Triple +compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple +compString: (%Form,%Mode,%Env) -> %Maybe %Triple +compAtomWithModemap: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple +compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple +compForm: (%Form,%Mode,%Env) -> %Maybe %Triple +compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple +compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple +compExpressionList: (%List,%Mode,%Env) -> %Maybe %Triple +compWithMappingMode: (%Form,%Mode,%List) -> %List +compFormMatch: (%Modemap,%List) -> %Boolean +compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple +compApply: (%List,%List,%Thing,%List,%Mode,%Env) -> %Maybe %Triple +compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple +compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple +compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple + +primitiveType: %Thing -> %Mode +hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean +convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple +getFormModemaps: (%Form,%Env) -> %List +transImplementation: (%Form,%Modemap,%Thing) -> %Code +reshapeArgumentList: (%Form,%Signature) -> %Form +applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code +compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code +compMapCond'': (%Thing,%Mode) -> %Boolean +compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code + ++ A list of routines for diagnostic reports. These functions, in an ++ abstract sense, have type: forall T: Type . String -> T, so they @@ -62,16 +110,13 @@ compTopLevel(x,m,e) == --keep old environment after top level function defs compOrCroak(x,m,e) -compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple compUniquely(x,m,e) == $compUniquelyIfTrue: local:= true CATCH("compUniquely",comp(x,m,e)) -compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp) -compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple compOrCroak1(x,m,e,compFn) == fn(x,m,e,nil,nil,compFn) where fn(x,m,e,$compStack,$compErrorMessageStack,compFn) == @@ -103,7 +148,6 @@ tc() == ++ The form `x' is intended to be evaluated by the compiler, e.g. in ++ toplevel conditional definition or as sub-domain predicate. ++ Normalize operators and compile the form. -compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple compCompilerPredicate(x,e) == savedNormalizeTree := $normalizeTree $normalizeTree := true @@ -112,13 +156,11 @@ compCompilerPredicate(x,e) == t -comp: (%Form,%Mode,%Env) -> %Maybe %Triple comp(x,m,e) == T:= compNoStacking(x,m,e) => ($compStack:= nil; T) $compStack:= [[x,m,e,$exitModeStack],:$compStack] nil -compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple compNoStacking(x,m,e) == T:= comp2(x,m,e) => $useRepresentationHack and m=$EmptyMode and T.mode=$Representation => @@ -131,13 +173,11 @@ compNoStacking(x,m,e) == --hack only when `Rep' is defined the old way. -- gdr 2008/01/26 compNoStacking1(x,m,e,$compStack) -compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple compNoStacking1(x,m,e,$compStack) == u:= get(RepIfRepHack m,"value",e) => (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) nil -comp2: (%Form,%Mode,%Env) -> %Maybe %Triple comp2(x,m,e) == [y,m',e]:= comp3(x,m,e) or return nil if $LISPLIB and isDomainForm(x,e) then @@ -150,7 +190,6 @@ comp2(x,m,e) == --$bootStrapMode-test necessary for compiling Ring in $bootStrapMode [y,m',e] -comp3: (%Form,%Mode,%Env) -> %Maybe %Triple comp3(x,m,$e) == --returns a Triple or %else nil to signalcan't do' $e:= addDomain(m,$e) @@ -175,20 +214,45 @@ comp3(x,m,$e) == [x',m',addDomain(m',e')] t -compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple compTypeOf(x:=[op,:argl],m,e) == $insideCompTypeOf: local := true newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e)) e:= put(op,'modemap,newModemap,e) comp3(x,m,e) +applyMapping([op,:argl],m,e,ml) == + #argl^=#ml-1 => nil + isCategoryForm(first ml,e) => + --is op a functor? + pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] + ml' := SUBLIS(pairlis, ml) + 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 + form:= [op,:argl'] + convert([form,first ml',e],m) + 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 + form:= + not member(op,$formalArgList) and ATOM op and not 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) + ['call,['applyFun,op],:argl'] + pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] + convert([form,SUBLIS(pairlis,first ml),e],m) + hasFormalMapVariable(x, vl) == $formalMapVariables: local := vl null vl => false ScanOrPairVec(function hasone?,x) where hasone? x == MEMQ(x,$formalMapVariables) -compWithMappingMode: (%Form,%Mode,%List) -> %List compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) == $killOptimizeIfTrue: local:= true e:= oldE @@ -292,7 +356,6 @@ extractCodeAndConstructTriple(u, m, oldE) == [op,:.,env] := u [["CONS",["function",op],env],m,oldE] -compExpression: (%Form,%Mode,%Env) -> %Maybe %Triple compExpression(x,m,e) == $insideExpressionIfTrue: local:= true -- special forms have dedicated compilers. @@ -300,7 +363,21 @@ compExpression(x,m,e) == FUNCALL(fn,x,m,e) compForm(x,m,e) -compAtom: (%Form,%Mode,%Env) -> %Maybe %Triple +compAtomWithModemap(x,m,e,v) == + Tl := + [[transImplementation(x,map,fn),target,e] + for map in v | map is [[.,target],[.,fn]]] => + --accept only monadic operators + T:= or/[t for (t:= [.,target,.]) in Tl | modeEqual(m,target)] => T + 1=#(Tl:= [y for t in Tl | (y:= convert(t,m))]) => first Tl + 0<#Tl and m=$NoValueMode => first Tl + nil + +transImplementation(op,map,fn) == + fn := genDeltaEntry [op,:map] + fn is ["XLAM",:.] => [fn] + ["call",fn] + compAtom(x,m,e) == T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T x="nil" => @@ -316,7 +393,6 @@ compAtom(x,m,e) == [x,primitiveType x or return nil,e] convert(t,m) -primitiveType: %Thing -> %Mode primitiveType x == x is nil => $EmptyMode STRINGP x => $String @@ -327,7 +403,6 @@ primitiveType x == FLOATP x => $DoubleFloat nil -compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple compSymbol(s,m,e) == s="$NoValue" => ["$NoValue",$NoValueMode,e] isFluid s => [s,getmode(s,e) or return nil,e] @@ -352,7 +427,6 @@ compSymbol(s,m,e) == ++ Return true if `m' is the most recent unique type case assumption ++ on `x' that predates its declaration in environment `e'. -hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean hasUniqueCaseView(x,m,e) == props := getProplist(x,e) for [p,:v] in props repeat @@ -360,13 +434,11 @@ hasUniqueCaseView(x,m,e) == p = "value" => return false -convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple convertOrCroak(T,m) == u:= convert(T,m) => u userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", " TO MODE: ",m,"%l"] -convert: (%Triple,%Mode) -> %Maybe %Triple convert(T,m) == coerce(T,resolve(T.mode,m) or return nil) @@ -391,13 +463,6 @@ hasType(x,e) == --% General Forms -compForm: (%Form,%Mode,%Env) -> %Maybe %Triple -compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple -compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple -compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple -compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple -compExpressionList: (%List,%Mode,%Env) -> %Maybe %Triple - compForm(form,m,e) == T:= compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return @@ -494,7 +559,6 @@ compForm2(form is [op,:argl],m,e,modemapList) == ++ We are about to compile a call. Returns true if each argument ++ partially matches (as could be determined by type inference) the ++ corresponding expected type in the callee's modemap. -compFormMatch: (%Modemap,%List) -> %Boolean compFormMatch(mm,partialModeList) == main where main() == mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList) @@ -519,12 +583,75 @@ compForm3(form is [op,:argl],m,e,modemapList) == T T + +compFormWithModemap(form,m,e,modemap) == + [map:= [.,target,:sig],[pred,impl]]:= modemap + [op,:argl] := form := reshapeArgumentList(form,sig) + if isCategoryForm(target,e) and isFunctor op then + [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil + [map:= [.,target,:.],:cexpr]:= modemap + sv:=listOfSharpVars map + if sv then + -- SAY [ "compiling ", op, " in compFormWithModemap, + -- mode= ",map," sharp vars=",sv] + for x in argl for ss in $FormalMapVariableList repeat + if ss in sv then + [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) + -- SAY ["new map is",map] + not (target':= coerceable(target,m,e)) => nil + map:= [target',:rest map] + [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil + + --generate code; return + T:= + [x',m',e'] where + m':= SUBLIS(sl,map.(1)) + x':= + form':= [f,:[t.expr for t in Tl]] + m'=$Category or isCategoryForm(m',e) => form' + -- try to deal with new-style Unions where we know the conditions + op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and + (c:=get(z,'condition,e)) and + c is [["case",=z,c1]] and + (c1 is [":",=(CADR argl),=m] or EQ(c1,CADR argl) ) => +-- first is a full tag, as placed by getInverseEnvironment +-- second is what getSuccessEnvironment will place there + ["CDR",z] + ["call",:form'] + e':= + Tl => (LAST Tl).env + e + convert(T,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:= SUBLIS(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 member(op,$formalArgList) and ATOM op => +-- [op',:argl',"$"] where +-- op':= INTERN STRCONC(STRINGIMAGE $prefix,";",STRINGIMAGE op) +-- ["call",["applyFun",op],:argl'] +-- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] +-- convert([form,SUBLIS(pairlis,first ml),e],m) + + ++ Returns the list of candidate modemaps for a form. A modemap ++ is candidate for a form if its signature has the same number ++ of paramter types as arguments supplied to the form. A special ++ case is made for a modemap whose sole parameter type is a Tuple. ++ In that case, it matches any number of supplied arguments. -getFormModemaps: (%Form,%Env) -> %List getFormModemaps(form is [op,:argl],e) == op is ["elt",domain,op1] => [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] @@ -555,7 +682,6 @@ getFormModemaps(form is [op,:argl],e) == ++ the same arity and must take flag argument in the same position. ++ Returns a vector of length `nargs' with positive entries indicating ++ flag arguments, and negative entries for normal argument passing. -checkCallingConvention: (%List,%Short) -> %SimpleArray %Short checkCallingConvention(sigs,nargs) == v := makeFilledSimpleArray("%Short",nargs,0) for sig in sigs repeat @@ -585,6 +711,52 @@ seteltModemapFilter(name,mmList,e) == nil mmList + +compApply(sig,varl,body,argl,m,e) == + argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl] + contour:= + [Pair(x,[["mode",m'],["value",removeEnv comp(a,m',e)]]) + for x in varl for m' in sig.source for a in argl] + code:= [["LAMBDA",varl,body'],:[T.expr for T in argTl]] + m':= resolve(m,sig.target) + body':= (comp(body,m',addContour(contour,e))).expr + [code,m',e] + +compToApply(op,argl,m,e) == + T:= compNoStacking(op,$EmptyMode,e) or return nil + m1:= T.mode + T.expr is ["QUOTE", =m1] => nil + compApplication(op,argl,m,T.env,T) + +compApplication(op,argl,m,e,T) == + T.mode is ['Mapping, retm, :argml] => + #argl ^= #argml => nil + retm := resolve(m, retm) + retm = $Category or isCategoryForm(retm,e) => nil -- not handled + argTl := [[.,.,e] := comp(x,m,e) or return "failed" + for x in argl for m in argml] + argTl = "failed" => nil + form:= + not (member(op,$formalArgList) or member(T.expr,$formalArgList)) and ATOM T.expr => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:[a.expr for a in argTl],"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr) + ['call, ['applyFun, T.expr], :[a.expr for a in argTl]] + coerce([form, retm, e],resolve(retm,m)) + op = 'elt => nil + eltForm := ['elt, op, :argl] + comp(eltForm, m, e) + +++ `form' is a call to a operation described by the signature `sig'. +++ Massage the call so that homogeneous variable length argument lists +++ are properly tuplified. +reshapeArgumentList(form,sig) == + [op,:args] := form + wantArgumentsAsTuple(args,sig) => [op,["%Comma",:args]] + form + substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == #dc^=#sig => keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap", @@ -602,7 +774,6 @@ substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == compConstructorCategory(x,m,e) == [x,resolve($Category,m),e] -compString: (%Form,%Mode,%Env) -> %Maybe %Triple compString(x,m,e) == [x,resolve($StringCategory,m),e] --% SUBSET CATEGORY @@ -1258,7 +1429,6 @@ compIs(["is",a,b],m,e) == -- One should always call the correct function, since the represent- -- ation of basic objects may not be the same. -coerce: (%Triple,%Mode) -> %Maybe %Triple coerce(T,m) == $InteractiveMode => keyedSystemError("S2GE0016",['"coerce", @@ -1645,7 +1815,76 @@ compCat(form is [functorName,:argl],m,e) == --sure if it uses any of the other signatures(see extendsCategoryForm) [form,catForm,e] - +--% APPLY MODEMAPS + +compApplyModemap(form,modemap,$e,sl) == + [op,:argl] := form --form to be compiled + [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing + + -- $e is the current environment + -- sl substitution list, nil means bottom-up, otherwise top-down + + -- 0. fail immediately if #argl=#margl + + if #argl^=#margl then return nil + + -- 1. use modemap to evaluate arguments, returning failed if + -- not possible + + lt:= + [[.,m',$e]:= + comp(y,g,$e) or return "failed" where + g:= SUBLIS(sl,m) where + sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] + lt="failed" => return nil + + -- 2. coerce each argument to final domain, returning failed + -- if not possible + + lt':= [coerce(y,d) or return "failed" + for y in lt for d in SUBLIS(sl,margl)] + lt'="failed" => return nil + + -- 3. obtain domain-specific function, if possible, and return + + --$bindings is bound by compMapCond + [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil + +--+ can no longer trust what the modemap says for a reference into +--+ an exterior domain (it is calculating the displacement based on view +--+ information which is no longer valid; thus ignore this index and +--+ store the signature instead. + + f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => + [genDeltaEntry [op,:modemap],lt',$bindings] + [f,lt',$bindings] + +compMapCond(op,mc,$bindings,fnsel) == + or/[compMapCond'(u,op,mc,$bindings) for u in fnsel] + +compMapCond'([cexpr,fnexpr],op,dc,bindings) == + compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings) + stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) + +compMapCond''(cexpr,dc) == + cexpr=true => true + --cexpr = "true" => true + cexpr is ["AND",:l] => and/[compMapCond''(u,dc) for u in l] + cexpr is ["OR",:l] => or/[compMapCond''(u,dc) for u in l] + cexpr is ["not",u] => not compMapCond''(u,dc) + cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + --for the time being we'll stop here - shouldn't happen so far + --$disregardConditionIfTrue => true + --stackSemanticError(("not known that",'%b,name, + -- '%d,"has",'%b,cat,'%d),nil) + --now it must be an attribute + member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true + --for the time being we'll stop here - shouldn't happen so far + stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) + false + +compMapCondFun(fnexpr,op,dc,bindings) == + [fnexpr,bindings] --% Interface to the backend |