diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/interp/c-util.boot | 16 | ||||
| -rw-r--r-- | src/interp/clam.boot | 35 | ||||
| -rw-r--r-- | src/interp/define.boot | 45 | ||||
| -rw-r--r-- | src/interp/slam.boot | 29 |
4 files changed, 60 insertions, 65 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 50b70484..2ad1bd00 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -40,10 +40,10 @@ module c_-util where makeWorkerName: %Symbol -> %Symbol clearReplacement: %Symbol -> %Thing replaceSimpleFunctions: %Form -> %Form - foldExportedFunctionReferences: %List %Form -> %List %Form + foldExportedFunctionReferences: (%Database,%List %Code) -> %List %Code diagnoseUnknownType: (%Mode,%Env) -> %Form declareUnusedParameters: %Code -> %Code - registerFunctionReplacement: (%Symbol,%Form) -> %Thing + registerFunctionReplacement: (%Database,%Symbol,%Form) -> %Thing getSuccessEnvironment: (%Form,%Env) -> %Env getInverseEnvironment: (%Form,%Env) -> %Env giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env @@ -1309,12 +1309,12 @@ clearReplacement name == property(name,'%redex) := nil ++ Register the inlinable form of a function. -registerFunctionReplacement(name,body) == +registerFunctionReplacement(db,name,body) == evalAndPrintBackendStmt ["PUT",MKQ name,MKQ "SPADreplace",quoteMinimally body] ++ Remember the redex form of this function -registerRedexForm(name,parms,body) == +registerRedexForm(db,name,parms,body) == evalAndPrintBackendStmt ["PUT",quote name,quote '%redex,quote ['ILAM,parms,body]] @@ -1454,17 +1454,17 @@ almostPure? x == ++ `defs' is a list of function definitions from the current domain. ++ Walk that list and replace references to unconditional operations ++ with their corresponding linkage names. -foldExportedFunctionReferences defs == +foldExportedFunctionReferences(db,defs) == for fun in defs repeat fun isnt [name,lamex] => nil getFunctionReplacement name => nil lamex isnt ['%lambda,vars,body] => nil body := replaceSimpleFunctions body form := expandableDefinition?(vars,body) => - registerFunctionReplacement(name,form) + registerFunctionReplacement(db,name,form) second(fun) := ["LAMBDA",vars,["DECLARE",["IGNORE",last vars]],body] if almostPure? body then - registerRedexForm(name,vars,body) + registerRedexForm(db,name,vars,body) lamex.absBody := body defs @@ -1491,7 +1491,7 @@ setCompilerOptimizations level == ++ Proclaim the type of the capsule function `op' with signature `sig'. ++ Note that all capsule functions take an additional argument ++ standing for the domain of computation object. -proclaimCapsuleFunction(op,sig) == +proclaimCapsuleFunction(db,op,sig) == printBackendStmt ["DECLAIM",["FTYPE", ["FUNCTION",[:[vmType first d for d in tails rest sig],"%Shell"], diff --git a/src/interp/clam.boot b/src/interp/clam.boot index 6b8cbaa9..c921e953 100644 --- a/src/interp/clam.boot +++ b/src/interp/clam.boot @@ -80,41 +80,6 @@ $clamList == ++ $failed := '"failed" -compHash(op,argl,body) == --- Entries will be stored on the global hashtable in a uniform way: --- (<argument list>, <reference count>,:<value>) --- where the reference count is optional - auxfn := makeWorkerName op - cacheName := "$ConstructorCache" - g2 := gensym() --value computed by calling function - putCode := - argl = nil => - ['CDDAR,['%store,['tableValue,cacheName,MKQ op], - ['%list,['%pair,'%nil,['%pair,1,[auxfn]]]]]] - [auxfn,:argl] - putCode := - ['UNWIND_-PROTECT,['PROG1,putCode,['%store,g2,'%true]], - ['%when,[['%not,g2],['tableRemove!,cacheName,MKQ op]]]] - getCode := - argl = nil => ['tableValue,cacheName,MKQ op] - key := - argl is [g] => ['%list,['devaluate,g]] - ['%list,:[['devaluate,x] for x in argl]] - ['lassocShiftWithFunction,key, - ['tableValue,cacheName,MKQ op],['%function,'domainEqualList]] - returnFoundValue := - argl = nil => ['CDRwithIncrement,['CDAR,g2]] - ['CDRwithIncrement,g2] - codeBody := mkBind([[g2,getCode]], - ['%when,[g2,returnFoundValue],['%otherwise,putCode]]) - - computeFunction := [auxfn,['%lambda,argl,:body]] - if $reportCompilation then - sayBrightlyI bright '"Generated code for function:" - pp computeFunction - compQuietly [[op,['%lambda,argl,codeBody]],computeFunction] - op - CDRwithIncrement x == x.first := first x + 1 rest x diff --git a/src/interp/define.boot b/src/interp/define.boot index 464e8f00..ff3789aa 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -1588,7 +1588,7 @@ compFunctorBody(db,body,m,e) == -- ??? Don't resolve default definitions, yet. backendCompile $insideCategoryPackageIfTrue => $capsuleFunctionStack - foldExportedFunctionReferences $capsuleFunctionStack + foldExportedFunctionReferences(db,$capsuleFunctionStack) clearCapsuleDirectory() -- release storage. body is [op,:.] and op in '(add CAPSULE) => T $NRTaddForm := @@ -1984,7 +1984,7 @@ compDefineCapsuleFunction(db,df is ['DEF,form,signature,body], updateCapsuleDirectory([n,:op'],pred) -- Let the backend know about this function's type if $optProclaim then - proclaimCapsuleFunction(op',signature) + proclaimCapsuleFunction(db,op',signature) clearReplacement op' -- Make sure we have fresh info -- Finally, build a lambda expression for this function. fun := @@ -2120,10 +2120,10 @@ spadCompileOrSetq(db,form is [nam,[lam,vl,body]]) == body := replaceSimpleFunctions body if nam' := forwardingCall?(vl,body) then - registerFunctionReplacement(nam,nam') + registerFunctionReplacement(db,nam,nam') sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] else if macform := expandableDefinition?(vl,body) then - registerFunctionReplacement(nam,macform) + registerFunctionReplacement(db,nam,macform) [:vl',.] := vl sayBrightly ['" ",:bright prefix2String [nam,:vl'], '"is replaced by",:bright prefix2String body] @@ -2154,7 +2154,42 @@ compileConstructor1(db,form:=[fn,[key,vl,:bodyl]]) == first compAndDefine [[fn,['%slam,vl,:bodyl]]] dbInstanceCache db = nil => first backendCompile [[fn,['%lambda,vl,:bodyl]]] - compHash(fn,vl,bodyl) + compHash(db,fn,vl,bodyl) + +compHash(db,op,argl,body) == +-- Entries will be stored on the global hashtable in a uniform way: +-- (<argument list>, <reference count>,:<value>) +-- where the reference count is optional + auxfn := makeWorkerName op + cacheName := "$ConstructorCache" + g2 := gensym() --value computed by calling function + putCode := + argl = nil => + ['CDDAR,['%store,['tableValue,cacheName,MKQ op], + ['%list,['%pair,'%nil,['%pair,1,[auxfn]]]]]] + [auxfn,:argl] + putCode := + ['UNWIND_-PROTECT,['PROG1,putCode,['%store,g2,'%true]], + ['%when,[['%not,g2],['tableRemove!,cacheName,MKQ op]]]] + getCode := + argl = nil => ['tableValue,cacheName,MKQ op] + key := + argl is [g] => ['%list,['devaluate,g]] + ['%list,:[['devaluate,x] for x in argl]] + ['lassocShiftWithFunction,key, + ['tableValue,cacheName,MKQ op],['%function,'domainEqualList]] + returnFoundValue := + argl = nil => ['CDRwithIncrement,['CDAR,g2]] + ['CDRwithIncrement,g2] + codeBody := mkBind([[g2,getCode]], + ['%when,[g2,returnFoundValue],['%otherwise,putCode]]) + + computeFunction := [auxfn,['%lambda,argl,:body]] + if $reportCompilation then + sayBrightlyI bright '"Generated code for function:" + pp computeFunction + backendCompile [[op,['%lambda,argl,codeBody]],computeFunction] + op constructMacro: %Form -> %Form constructMacro (form is [nam,[lam,vl,body]]) == diff --git a/src/interp/slam.boot b/src/interp/slam.boot index ded60ffa..16cd8bcb 100644 --- a/src/interp/slam.boot +++ b/src/interp/slam.boot @@ -392,26 +392,21 @@ clearLocalModemaps x == $e compileInteractive fn == - if $InteractiveMode then startTimingProcess 'compilation - if fn is [.,[bindOp,.,.]] and abstractionOperator? bindOp then - fn := [first fn,declareUnusedParameters second fn] - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp fn - optfn := - $InteractiveMode => [timedOptimization fn] - [fn] - result := compQuietly optfn - if $InteractiveMode then stopTimingProcess 'compilation - result + try + startTimingProcess 'compilation + if fn is [.,[bindOp,.,.]] and abstractionOperator? bindOp then + fn := [first fn,declareUnusedParameters second fn] + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp fn + compQuietly [timedOptimization fn] + finally stopTimingProcess 'compilation ++ Subroutine of compileInteractive. compQuietly fn == - _*COMP370_-APPLY_* := - $InteractiveMode => - $compileDontDefineFunctions => "COMPILE-DEFUN" - "EVAL-DEFUN" - function printBackendDecl + _*COMP370_-APPLY_*: local := + $compileDontDefineFunctions => "COMPILE-DEFUN" + "EVAL-DEFUN" quietlyIfInteractive backendCompile fn clearAllSlams x == |