From 16ba9fbd8041697a0b3f23ec3bb0117216759ec0 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 15 Jun 2009 17:09:20 +0900 Subject: [PATCH 01/49] extra/central implements the "central" pattern --- extra/central/authors.txt | 1 + extra/central/central-docs.factor | 10 ++++++++++ extra/central/central-tests.factor | 7 +++++++ extra/central/central.factor | 16 ++++++++++++++++ extra/central/tags.txt | 1 + 5 files changed, 35 insertions(+) create mode 100644 extra/central/authors.txt create mode 100644 extra/central/central-docs.factor create mode 100644 extra/central/central-tests.factor create mode 100644 extra/central/central.factor create mode 100644 extra/central/tags.txt diff --git a/extra/central/authors.txt b/extra/central/authors.txt new file mode 100644 index 0000000000..5645cd91bd --- /dev/null +++ b/extra/central/authors.txt @@ -0,0 +1 @@ +Matthew Willis diff --git a/extra/central/central-docs.factor b/extra/central/central-docs.factor new file mode 100644 index 0000000000..f6a0ba5957 --- /dev/null +++ b/extra/central/central-docs.factor @@ -0,0 +1,10 @@ +USING: central help.markup help.syntax ; + +HELP: CENTRAL: +{ $description + "This parsing word defines a pair of words useful for " + "implementing the \"central\" pattern: " { $snippet "symbol" } " and " + { $snippet "with-symbol" } ". This is a middle ground between excessive " + "stack manipulation and full-out locals, meant to solve the case where " + "one object is operated on by several related words." +} ; \ No newline at end of file diff --git a/extra/central/central-tests.factor b/extra/central/central-tests.factor new file mode 100644 index 0000000000..576a1fac97 --- /dev/null +++ b/extra/central/central-tests.factor @@ -0,0 +1,7 @@ +USING: central tools.test ; + +IN: scratchpad + +CENTRAL: test-central + +[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test \ No newline at end of file diff --git a/extra/central/central.factor b/extra/central/central.factor new file mode 100644 index 0000000000..df100f2e5b --- /dev/null +++ b/extra/central/central.factor @@ -0,0 +1,16 @@ +USING: kernel lexer namespaces parser sequences words ; + +IN: central + +: define-central-getter ( word -- ) + dup [ get ] curry (( -- obj )) define-declared ; + +: define-central-setter ( word with-word -- ) + [ with-variable ] with (( object quot -- )) define-declared ; + +: define-central ( word-name -- ) + [ create-in dup define-central-getter ] keep + "with-" prepend create-in [ define-central-setter ] keep + make-inline ; + +SYNTAX: CENTRAL: ( -- ) scan define-central ; \ No newline at end of file diff --git a/extra/central/tags.txt b/extra/central/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/central/tags.txt @@ -0,0 +1 @@ +extensions From 56cb3c6f59f7b7bdae7f569c3fd6c6bce35b590e Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 15 Jun 2009 21:39:40 +0900 Subject: [PATCH 02/49] added DISPOSABLE-CENTRAL: to extra/central --- extra/central/central-docs.factor | 8 +++++++- extra/central/central-tests.factor | 16 ++++++++++++++-- extra/central/central.factor | 26 +++++++++++++++++++------- 3 files changed, 40 insertions(+), 10 deletions(-) diff --git a/extra/central/central-docs.factor b/extra/central/central-docs.factor index f6a0ba5957..458f528c53 100644 --- a/extra/central/central-docs.factor +++ b/extra/central/central-docs.factor @@ -1,4 +1,4 @@ -USING: central help.markup help.syntax ; +USING: central destructors help.markup help.syntax ; HELP: CENTRAL: { $description @@ -7,4 +7,10 @@ HELP: CENTRAL: { $snippet "with-symbol" } ". This is a middle ground between excessive " "stack manipulation and full-out locals, meant to solve the case where " "one object is operated on by several related words." +} ; + +HELP: DISPOSABLE-CENTRAL: +{ $description + "Like " { $link POSTPONE: CENTRAL: } ", but generates " { $snippet "with-" } + " words that are wrapped in a " { $link with-disposal } "." } ; \ No newline at end of file diff --git a/extra/central/central-tests.factor b/extra/central/central-tests.factor index 576a1fac97..3dbcbf32fc 100644 --- a/extra/central/central-tests.factor +++ b/extra/central/central-tests.factor @@ -1,7 +1,19 @@ -USING: central tools.test ; +USING: accessors central destructors kernel math tools.test ; IN: scratchpad CENTRAL: test-central -[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test \ No newline at end of file +[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test + +TUPLE: test-disp-cent value disposed ; + +! A phony destructor that adds 1 to the value so we can make sure it got called. +M: test-disp-cent dispose* dup value>> 1+ >>value drop ; + +DISPOSABLE-CENTRAL: t-d-c + +: test-t-d-c ( -- n ) + test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ; + +[ 4 ] [ test-t-d-c ] unit-test \ No newline at end of file diff --git a/extra/central/central.factor b/extra/central/central.factor index df100f2e5b..f7175141dd 100644 --- a/extra/central/central.factor +++ b/extra/central/central.factor @@ -1,16 +1,28 @@ -USING: kernel lexer namespaces parser sequences words ; +USING: destructors kernel lexer namespaces parser sequences words ; IN: central : define-central-getter ( word -- ) dup [ get ] curry (( -- obj )) define-declared ; -: define-central-setter ( word with-word -- ) - [ with-variable ] with (( object quot -- )) define-declared ; +: define-centrals ( str -- getter setter ) + [ create-in dup define-central-getter ] + [ "with-" prepend create-in dup make-inline ] bi ; + +: central-setter-def ( word with-word -- with-word quot ) + [ with-variable ] with ; + +: disposable-setter-def ( word with-word -- with-word quot ) + [ pick [ drop with-variable ] with-disposal ] with ; + +: declare-central ( with-word quot -- ) (( object quot -- )) define-declared ; : define-central ( word-name -- ) - [ create-in dup define-central-getter ] keep - "with-" prepend create-in [ define-central-setter ] keep - make-inline ; + define-centrals central-setter-def declare-central ; -SYNTAX: CENTRAL: ( -- ) scan define-central ; \ No newline at end of file +: define-disposable-central ( word-name -- ) + define-centrals disposable-setter-def declare-central ; + +SYNTAX: CENTRAL: ( -- ) scan define-central ; + +SYNTAX: DISPOSABLE-CENTRAL: ( -- ) scan define-disposable-central ; \ No newline at end of file From a021ba53fe83e4fbc4a9bc80e155aa785e35ab02 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 15 Jun 2009 21:42:13 +0900 Subject: [PATCH 03/49] Initial work on llvm bindings, with test --- work/llvm/authors.txt | 1 + work/llvm/core/core.factor | 325 +++++++++++++++++++++++++++++++++ work/llvm/engine/engine.factor | 59 ++++++ work/llvm/llvm-tests.factor | 32 ++++ work/llvm/llvm.factor | 85 +++++++++ work/llvm/tags.txt | 1 + 6 files changed, 503 insertions(+) create mode 100644 work/llvm/authors.txt create mode 100644 work/llvm/core/core.factor create mode 100644 work/llvm/engine/engine.factor create mode 100644 work/llvm/llvm-tests.factor create mode 100644 work/llvm/llvm.factor create mode 100644 work/llvm/tags.txt diff --git a/work/llvm/authors.txt b/work/llvm/authors.txt new file mode 100644 index 0000000000..5645cd91bd --- /dev/null +++ b/work/llvm/authors.txt @@ -0,0 +1 @@ +Matthew Willis diff --git a/work/llvm/core/core.factor b/work/llvm/core/core.factor new file mode 100644 index 0000000000..906364efeb --- /dev/null +++ b/work/llvm/core/core.factor @@ -0,0 +1,325 @@ +USING: alien.libraries alien.syntax ; + +IN: llvm.core + +<< + +"LLVMSystem" "/usr/local/lib/libLLVMSystem.dylib" "cdecl" add-library + +"LLVMSupport" "/usr/local/lib/libLLVMSupport.dylib" "cdecl" add-library + +"LLVMCore" "/usr/local/lib/libLLVMCore.dylib" "cdecl" add-library + +>> + +! llvm-c/Core.h + +LIBRARY: LLVMCore + +TYPEDEF: uint unsigned +TYPEDEF: unsigned enum + +CONSTANT: LLVMZExtAttribute BIN: 1 +CONSTANT: LLVMSExtAttribute BIN: 10 +CONSTANT: LLVMNoReturnAttribute BIN: 100 +CONSTANT: LLVMInRegAttribute BIN: 1000 +CONSTANT: LLVMStructRetAttribute BIN: 10000 +CONSTANT: LLVMNoUnwindAttribute BIN: 100000 +CONSTANT: LLVMNoAliasAttribute BIN: 1000000 +CONSTANT: LLVMByValAttribute BIN: 10000000 +CONSTANT: LLVMNestAttribute BIN: 100000000 +CONSTANT: LLVMReadNoneAttribute BIN: 1000000000 +CONSTANT: LLVMReadOnlyAttribute BIN: 10000000000 +TYPEDEF: enum LLVMAttribute; + +C-ENUM: + LLVMVoidTypeKind + LLVMFloatTypeKind + LLVMDoubleTypeKind + LLVMX86_FP80TypeKind + LLVMFP128TypeKind + LLVMPPC_FP128TypeKind + LLVMLabelTypeKind + LLVMIntegerTypeKind + LLVMFunctionTypeKind + LLVMStructTypeKind + LLVMArrayTypeKind + LLVMPointerTypeKind + LLVMOpaqueTypeKind + LLVMVectorTypeKind ; +TYPEDEF: enum LLVMTypeKind + +C-ENUM: + LLVMExternalLinkage + LLVMLinkOnceLinkage + LLVMWeakLinkage + LLVMAppendingLinkage + LLVMInternalLinkage + LLVMDLLImportLinkage + LLVMDLLExportLinkage + LLVMExternalWeakLinkage + LLVMGhostLinkage ; +TYPEDEF: enum LLVMLinkage + +C-ENUM: + LLVMDefaultVisibility + LLVMHiddenVisibility + LLVMProtectedVisibility ; +TYPEDEF: enum LLVMVisibility + +CONSTANT: LLVMCCallConv 0 +CONSTANT: LLVMFastCallConv 8 +CONSTANT: LLVMColdCallConv 9 +CONSTANT: LLVMX86StdcallCallConv 64 +CONSTANT: LLVMX86FastcallCallConv 65 +TYPEDEF: enum LLVMCallConv + +CONSTANT: LLVMIntEQ 32 +CONSTANT: LLVMIntNE 33 +CONSTANT: LLVMIntUGT 34 +CONSTANT: LLVMIntUGE 35 +CONSTANT: LLVMIntULT 36 +CONSTANT: LLVMIntULE 37 +CONSTANT: LLVMIntSGT 38 +CONSTANT: LLVMIntSGE 39 +CONSTANT: LLVMIntSLT 40 +CONSTANT: LLVMIntSLE 41 +TYPEDEF: enum LLVMIntPredicate + +C-ENUM: + LLVMRealPredicateFalse + LLVMRealOEQ + LLVMRealOGT + LLVMRealOGE + LLVMRealOLT + LLVMRealOLE + LLVMRealONE + LLVMRealORD + LLVMRealUNO + LLVMRealUEQ + LLVMRealUGT + LLVMRealUGE + LLVMRealULT + LLVMRealULE + LLVMRealUNE + LLVMRealPredicateTrue ; +TYPEDEF: enum LLVMRealPredicate + +! Opaque Types + +TYPEDEF: void* LLVMModuleRef + +TYPEDEF: void* LLVMPassManagerRef + +TYPEDEF: void* LLVMModuleProviderRef + +TYPEDEF: void* LLVMTypeRef + +TYPEDEF: void* LLVMValueRef + +TYPEDEF: void* LLVMBasicBlockRef + +TYPEDEF: void* LLVMBuilderRef + +! Functions + +FUNCTION: void LLVMDisposeMessage ( char *Message ) ; + +FUNCTION: LLVMModuleRef LLVMModuleCreateWithName ( char* ModuleID ) ; + +FUNCTION: int LLVMAddTypeName ( LLVMModuleRef M, char* Name, LLVMTypeRef Ty ) ; + +FUNCTION: void LLVMDisposeModule ( LLVMModuleRef M ) ; + +FUNCTION: void LLVMDumpModule ( LLVMModuleRef M ) ; + +FUNCTION: LLVMModuleProviderRef +LLVMCreateModuleProviderForExistingModule ( LLVMModuleRef M ) ; + +FUNCTION: void LLVMDisposeModuleProvider ( LLVMModuleProviderRef MP ) ; + +FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ; + +FUNCTION: LLVMTypeRef +LLVMFunctionType ( LLVMTypeRef ReturnType, + LLVMTypeRef* ParamTypes, + unsigned ParamCount, + int IsVarArg ) ; + +FUNCTION: unsigned LLVMCountParams ( LLVMValueRef Fn ) ; + +FUNCTION: void LLVMGetParams ( LLVMValueRef Fn, LLVMValueRef* Params ) ; + +FUNCTION: LLVMValueRef +LLVMAddFunction ( LLVMModuleRef M, char* Name, LLVMTypeRef FunctionTy ) ; + +FUNCTION: unsigned LLVMGetFunctionCallConv ( LLVMValueRef Fn ) ; + +FUNCTION: void LLVMSetFunctionCallConv ( LLVMValueRef Fn, unsigned CC ) ; + +FUNCTION: LLVMBasicBlockRef +LLVMAppendBasicBlock ( LLVMValueRef Fn, char* Name ) ; + +FUNCTION: LLVMValueRef LLVMGetBasicBlockParent ( LLVMBasicBlockRef BB ) ; + +! Values + +FUNCTION: LLVMTypeRef LLVMTypeOf ( LLVMValueRef Val ) ; +FUNCTION: char* LLVMGetValueName ( LLVMValueRef Val ) ; +FUNCTION: void LLVMSetValueName ( LLVMValueRef Val, char* Name ) ; +FUNCTION: void LLVMDumpValue ( LLVMValueRef Val ) ; + +! Instruction Builders + +FUNCTION: LLVMBuilderRef LLVMCreateBuilder ( ) ; +FUNCTION: void LLVMPositionBuilder +( LLVMBuilderRef Builder, LLVMBasicBlockRef Block, LLVMValueRef Instr ) ; +FUNCTION: void LLVMPositionBuilderBefore +( LLVMBuilderRef Builder, LLVMValueRef Instr ) ; +FUNCTION: void LLVMPositionBuilderAtEnd +( LLVMBuilderRef Builder, LLVMBasicBlockRef Block ) ; +FUNCTION: LLVMBasicBlockRef LLVMGetInsertBlock +( LLVMBuilderRef Builder ) ; +FUNCTION: void LLVMClearInsertionPosition +( LLVMBuilderRef Builder ) ; +FUNCTION: void LLVMInsertIntoBuilder +( LLVMBuilderRef Builder, LLVMValueRef Instr ) ; +FUNCTION: void LLVMDisposeBuilder +( LLVMBuilderRef Builder ) ; + +! IB Terminators + +FUNCTION: LLVMValueRef LLVMBuildRetVoid +( LLVMBuilderRef Builder ) ; +FUNCTION: LLVMValueRef LLVMBuildRet +( LLVMBuilderRef Builder, LLVMValueRef V ) ; +FUNCTION: LLVMValueRef LLVMBuildBr +( LLVMBuilderRef Builder, LLVMBasicBlockRef Dest ) ; +FUNCTION: LLVMValueRef LLVMBuildCondBr +( LLVMBuilderRef Builder, LLVMValueRef If, LLVMBasicBlockRef Then, LLVMBasicBlockRef Else ) ; +FUNCTION: LLVMValueRef LLVMBuildSwitch +( LLVMBuilderRef Builder, LLVMValueRef V, LLVMBasicBlockRef Else, unsigned NumCases ) ; +FUNCTION: LLVMValueRef LLVMBuildInvoke +( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef *Args, unsigned NumArgs, + LLVMBasicBlockRef Then, LLVMBasicBlockRef Catch, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildUnwind +( LLVMBuilderRef Builder ) ; +FUNCTION: LLVMValueRef LLVMBuildUnreachable +( LLVMBuilderRef Builder ) ; + +! IB Add Case to Switch + +FUNCTION: void LLVMAddCase +( LLVMValueRef Switch, LLVMValueRef OnVal, LLVMBasicBlockRef Dest ) ; + +! IB Arithmetic + +FUNCTION: LLVMValueRef LLVMBuildAdd +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSub +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildMul +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildUDiv +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSDiv +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFDiv +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildURem +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSRem +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFRem +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildShl +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildLShr +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildAShr +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildAnd +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildOr +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildXor +( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildNeg +( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildNot +( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ; + +! IB Memory + +FUNCTION: LLVMValueRef LLVMBuildMalloc +( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildArrayMalloc +( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildAlloca +( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildArrayAlloca +( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFree +( LLVMBuilderRef Builder, LLVMValueRef PointerVal ) ; +FUNCTION: LLVMValueRef LLVMBuildLoad +( LLVMBuilderRef Builder, LLVMValueRef PointerVal, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildStore +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMValueRef Ptr ) ; +FUNCTION: LLVMValueRef LLVMBuildGEP +( LLVMBuilderRef B, LLVMValueRef Pointer, LLVMValueRef *Indices, + unsigned NumIndices, char* Name ) ; + +! IB Casts + +FUNCTION: LLVMValueRef LLVMBuildTrunc +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildZExt +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSExt +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFPToUI +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFPToSI +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildUIToFP +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSIToFP +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFPTrunc +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFPExt +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildPtrToInt +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildIntToPtr +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildBitCast +( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ; + +! IB Comparisons + +FUNCTION: LLVMValueRef LLVMBuildICmp +( LLVMBuilderRef Builder, LLVMIntPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildFCmp +( LLVMBuilderRef Builder, LLVMRealPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ; + +! IB Misc Instructions + +FUNCTION: LLVMValueRef LLVMBuildPhi +( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildCall +( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef *Args, unsigned NumArgs, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildSelect +( LLVMBuilderRef Builder, LLVMValueRef If, LLVMValueRef Then, LLVMValueRef Else, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildVAArg +( LLVMBuilderRef Builder, LLVMValueRef List, LLVMTypeRef Ty, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildExtractElement +( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef Index, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildInsertElement +( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef EltVal, LLVMValueRef Index, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildShuffleVector +( LLVMBuilderRef Builder, LLVMValueRef V1, LLVMValueRef V2, LLVMValueRef Mask, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildExtractValue +( LLVMBuilderRef Builder, LLVMValueRef AggVal, unsigned Index, char* Name ) ; +FUNCTION: LLVMValueRef LLVMBuildInsertValue +( LLVMBuilderRef Builder, LLVMValueRef AggVal, LLVMValueRef EltVal, unsigned Index, char* Name ) ; diff --git a/work/llvm/engine/engine.factor b/work/llvm/engine/engine.factor new file mode 100644 index 0000000000..db5c7014ef --- /dev/null +++ b/work/llvm/engine/engine.factor @@ -0,0 +1,59 @@ +USING: alien.libraries alien.syntax llvm.core ; +IN: llvm.engine + +<< + +"LLVMExecutionEngine" "/usr/local/lib/libLLVMExecutionEngine.dylib" "cdecl" add-library + +"LLVMTarget" "/usr/local/lib/libLLVMTarget.dylib" "cdecl" add-library + +"LLVMAnalysis" "/usr/local/lib/libLLVMAnalysis.dylib" "cdecl" add-library + +"LLVMipa" "/usr/local/lib/libLLVMipa.dylib" "cdecl" add-library + +"LLVMTransformUtils" "/usr/local/lib/libLLVMTransformUtils.dylib" "cdecl" add-library + +"LLVMScalarOpts" "/usr/local/lib/libLLVMScalarOpts.dylib" "cdecl" add-library + +"LLVMCodeGen" "/usr/local/lib/libLLVMCodeGen.dylib" "cdecl" add-library + +"LLVMAsmPrinter" "/usr/local/lib/libLLVMAsmPrinter.dylib" "cdecl" add-library + +"LLVMSelectionDAG" "/usr/local/lib/libLLVMSelectionDAG.dylib" "cdecl" add-library + +"LLVMX86CodeGen" "/usr/local/lib/libLLVMX86CodeGen.dylib" "cdecl" add-library + +"LLVMJIT" "/usr/local/lib/libLLVMJIT.dylib" "cdecl" add-library + +"LLVMInterpreter.dylib" "/usr/local/lib/libLLVMInterpreter.dylib" "cdecl" add-library + +>> + +! llvm-c/ExecutionEngine.h + +LIBRARY: LLVMExecutionEngine + +TYPEDEF: void* LLVMGenericValueRef +TYPEDEF: void* LLVMExecutionEngineRef + +FUNCTION: LLVMGenericValueRef LLVMCreateGenericValueOfInt +( LLVMTypeRef Ty, ulonglong N, int IsSigned ) ; + +FUNCTION: ulonglong LLVMGenericValueToInt +( LLVMGenericValueRef GenVal, int IsSigned ) ; + +FUNCTION: int LLVMCreateExecutionEngine +( LLVMExecutionEngineRef *OutEE, LLVMModuleProviderRef MP, char** OutError ) ; + +FUNCTION: int LLVMCreateJITCompiler +( LLVMExecutionEngineRef* OutJIT, LLVMModuleProviderRef MP, unsigned OptLevel, char** OutError ) ; + +FUNCTION: void LLVMDisposeExecutionEngine ( LLVMExecutionEngineRef EE ) ; + +FUNCTION: int LLVMFindFunction +( LLVMExecutionEngineRef EE, char* Name, LLVMValueRef* OutFn ) ; + +FUNCTION: void* LLVMGetPointerToGlobal ( LLVMExecutionEngineRef EE, LLVMValueRef Global ) ; + +FUNCTION: LLVMGenericValueRef LLVMRunFunction +( LLVMExecutionEngineRef EE, LLVMValueRef F, unsigned NumArgs, LLVMGenericValueRef* Args ) ; \ No newline at end of file diff --git a/work/llvm/llvm-tests.factor b/work/llvm/llvm-tests.factor new file mode 100644 index 0000000000..5ba1596d84 --- /dev/null +++ b/work/llvm/llvm-tests.factor @@ -0,0 +1,32 @@ +USING: accessors alien compiler.units kernel +llvm tools.test words llvm.core ; + +IN: scratchpad + +: add-abi ( x y -- x+y ) ! to be filled in by llvm + drop ; + +: llvm-add ( x y -- x+y ) + "test" [ + { + { [ 32 LLVMIntType ] "add" } + { [ 32 LLVMIntType ] "x" } + { [ 32 LLVMIntType ] "y" } + } [ + "entry" [ + builder value>> "x" get-param "y" get-param "sum" LLVMBuildAdd + builder value>> swap LLVMBuildRet drop + ] with-builder + ] with-function + + + ] with-module + + [ + "add" find-function global>pointer + [ "int" { "int" "int" } "cdecl" alien-indirect ] curry \ add-abi swap + (( x y -- x+y )) [ define-declared ] with-compilation-unit + add-abi ! call our new word + ] with-engine ; inline + +[ 7 ] [ 3 4 llvm-add ] unit-test \ No newline at end of file diff --git a/work/llvm/llvm.factor b/work/llvm/llvm.factor new file mode 100644 index 0000000000..8c6385e05d --- /dev/null +++ b/work/llvm/llvm.factor @@ -0,0 +1,85 @@ +USING: accessors alien.c-types alien.strings arrays +central destructors kernel llvm.core llvm.engine +quotations sequences specialized-arrays.alien ; + +IN: llvm + +: llvm-throw ( char** -- ) + *void* [ alien>string ] [ LLVMDisposeMessage ] bi throw ; + +DISPOSABLE-CENTRAL: module +CENTRAL: function +DISPOSABLE-CENTRAL: builder +DISPOSABLE-CENTRAL: engine + +: ( alien class -- disposable ) new swap >>value ; + +TUPLE: LLVMModule value disposed ; +M: LLVMModule dispose* value>> LLVMDisposeModule ; + +: ( name -- module ) + LLVMModuleCreateWithName LLVMModule ; + +TUPLE: LLVMModuleProvider value disposed ; +M: LLVMModuleProvider dispose* value>> LLVMDisposeModuleProvider ; + +: ( -- module-provider ) + module t >>disposed value>> LLVMCreateModuleProviderForExistingModule + LLVMModuleProvider ; + +: (add-block) ( name -- basic-block ) + function swap LLVMAppendBasicBlock ; + +TUPLE: LLVMBuilder value disposed ; +M: LLVMBuilder dispose* value>> LLVMDisposeBuilder ; + +: ( name -- builder ) + (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep + LLVMBuilder ; + +TUPLE: LLVMExecutionEngine value disposed ; +M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ; + +: ( -- engine ) + [ + dup value>> f f + [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep + *void* [ llvm-throw ] when* *void* LLVMExecutionEngine + swap t >>disposed drop + ] with-disposal ; + +: resolve-type ( callable/alien -- type ) + dup callable? [ call( -- type ) ] when ; + +: ( args -- type ) + [ resolve-type ] map + unclip swap [ >void*-array ] keep length 0 LLVMFunctionType ; + +: >>cc ( function calling-convention -- function ) + dupd LLVMSetFunctionCallConv ; + +: params>> ( function -- array ) + dup LLVMCountParams "LLVMValueRef" [ LLVMGetParams ] keep + byte-array>void*-array >array ; + +: get-param ( name -- value ) + function params>> swap [ swap LLVMGetValueName = ] curry find nip ; + +: set-param-names ( names function -- ) + params>> swap [ LLVMSetValueName ] 2each ; + +: ( args -- function ) + module value>> over first second pick + [ first ] map LLVMAddFunction LLVMCCallConv >>cc tuck + [ rest [ second ] map ] dip set-param-names ; + +: global>pointer ( value -- alien ) engine value>> swap LLVMGetPointerToGlobal ; + +: find-function ( name -- fn ) + engine value>> swap f [ LLVMFindFunction drop ] keep *void* ; + +: llvm-int ( n -- Value ) + 32 LLVMIntType swap 1 LLVMCreateGenericValueOfInt ; + +: prepare-args ( function seq -- f numargs args ) + over LLVMCountParams swap [ llvm-int ] map f suffix >void*-array ; \ No newline at end of file diff --git a/work/llvm/tags.txt b/work/llvm/tags.txt new file mode 100644 index 0000000000..bb863cf9a0 --- /dev/null +++ b/work/llvm/tags.txt @@ -0,0 +1 @@ +bindings From f2b4b9236aeb6d1c532b9b4ce6d85b26d93bd9b0 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 15 Jun 2009 21:46:19 +0900 Subject: [PATCH 04/49] moving llvm to extra --- {work => extra}/llvm/authors.txt | 0 {work => extra}/llvm/core/core.factor | 0 {work => extra}/llvm/engine/engine.factor | 0 {work => extra}/llvm/llvm-tests.factor | 0 {work => extra}/llvm/llvm.factor | 0 {work => extra}/llvm/tags.txt | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename {work => extra}/llvm/authors.txt (100%) rename {work => extra}/llvm/core/core.factor (100%) rename {work => extra}/llvm/engine/engine.factor (100%) rename {work => extra}/llvm/llvm-tests.factor (100%) rename {work => extra}/llvm/llvm.factor (100%) rename {work => extra}/llvm/tags.txt (100%) diff --git a/work/llvm/authors.txt b/extra/llvm/authors.txt similarity index 100% rename from work/llvm/authors.txt rename to extra/llvm/authors.txt diff --git a/work/llvm/core/core.factor b/extra/llvm/core/core.factor similarity index 100% rename from work/llvm/core/core.factor rename to extra/llvm/core/core.factor diff --git a/work/llvm/engine/engine.factor b/extra/llvm/engine/engine.factor similarity index 100% rename from work/llvm/engine/engine.factor rename to extra/llvm/engine/engine.factor diff --git a/work/llvm/llvm-tests.factor b/extra/llvm/llvm-tests.factor similarity index 100% rename from work/llvm/llvm-tests.factor rename to extra/llvm/llvm-tests.factor diff --git a/work/llvm/llvm.factor b/extra/llvm/llvm.factor similarity index 100% rename from work/llvm/llvm.factor rename to extra/llvm/llvm.factor diff --git a/work/llvm/tags.txt b/extra/llvm/tags.txt similarity index 100% rename from work/llvm/tags.txt rename to extra/llvm/tags.txt From f55d83a84eac5f7416ee865c06422bbc8c8e6f55 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 16 Jun 2009 08:53:16 +0900 Subject: [PATCH 05/49] remove some untested function extra/llvm --- extra/llvm/llvm.factor | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/extra/llvm/llvm.factor b/extra/llvm/llvm.factor index 8c6385e05d..f5538be2c1 100644 --- a/extra/llvm/llvm.factor +++ b/extra/llvm/llvm.factor @@ -5,7 +5,7 @@ quotations sequences specialized-arrays.alien ; IN: llvm : llvm-throw ( char** -- ) - *void* [ alien>string ] [ LLVMDisposeMessage ] bi throw ; + [ alien>string ] [ LLVMDisposeMessage ] bi throw ; DISPOSABLE-CENTRAL: module CENTRAL: function @@ -76,10 +76,4 @@ M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ; : global>pointer ( value -- alien ) engine value>> swap LLVMGetPointerToGlobal ; : find-function ( name -- fn ) - engine value>> swap f [ LLVMFindFunction drop ] keep *void* ; - -: llvm-int ( n -- Value ) - 32 LLVMIntType swap 1 LLVMCreateGenericValueOfInt ; - -: prepare-args ( function seq -- f numargs args ) - over LLVMCountParams swap [ llvm-int ] map f suffix >void*-array ; \ No newline at end of file + engine value>> swap f [ LLVMFindFunction drop ] keep *void* ; \ No newline at end of file From 27e95c7908049884ead0b65f4fdf56d982a213e1 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 16 Jun 2009 09:15:24 +0900 Subject: [PATCH 06/49] move llvm bindings to llvm.bindings --- extra/llvm/{llvm-tests.factor => binding/binding-tests.factor} | 0 extra/llvm/{llvm.factor => binding/binding.factor} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename extra/llvm/{llvm-tests.factor => binding/binding-tests.factor} (100%) rename extra/llvm/{llvm.factor => binding/binding.factor} (100%) diff --git a/extra/llvm/llvm-tests.factor b/extra/llvm/binding/binding-tests.factor similarity index 100% rename from extra/llvm/llvm-tests.factor rename to extra/llvm/binding/binding-tests.factor diff --git a/extra/llvm/llvm.factor b/extra/llvm/binding/binding.factor similarity index 100% rename from extra/llvm/llvm.factor rename to extra/llvm/binding/binding.factor From 08a3d907db42f5b986fa94f218a2a178eac13a8b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 16 Jun 2009 09:19:50 +0900 Subject: [PATCH 07/49] rename llvm.binding to llvm.bindings, update IN: --- .../binding-tests.factor => bindings/bindings-tests.factor} | 2 +- extra/llvm/{binding/binding.factor => bindings/bindings.factor} | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename extra/llvm/{binding/binding-tests.factor => bindings/bindings-tests.factor} (91%) rename extra/llvm/{binding/binding.factor => bindings/bindings.factor} (98%) diff --git a/extra/llvm/binding/binding-tests.factor b/extra/llvm/bindings/bindings-tests.factor similarity index 91% rename from extra/llvm/binding/binding-tests.factor rename to extra/llvm/bindings/bindings-tests.factor index 5ba1596d84..59eaf270f9 100644 --- a/extra/llvm/binding/binding-tests.factor +++ b/extra/llvm/bindings/bindings-tests.factor @@ -1,5 +1,5 @@ USING: accessors alien compiler.units kernel -llvm tools.test words llvm.core ; +llvm.bindings llvm.core tools.test words ; IN: scratchpad diff --git a/extra/llvm/binding/binding.factor b/extra/llvm/bindings/bindings.factor similarity index 98% rename from extra/llvm/binding/binding.factor rename to extra/llvm/bindings/bindings.factor index f5538be2c1..390b55aa37 100644 --- a/extra/llvm/binding/binding.factor +++ b/extra/llvm/bindings/bindings.factor @@ -2,7 +2,7 @@ USING: accessors alien.c-types alien.strings arrays central destructors kernel llvm.core llvm.engine quotations sequences specialized-arrays.alien ; -IN: llvm +IN: llvm.bindings : llvm-throw ( char** -- ) [ alien>string ] [ LLVMDisposeMessage ] bi throw ; From 45ee0a426992be72d68b41cd570bf4aab8473960 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Thu, 18 Jun 2009 20:47:08 +0200 Subject: [PATCH 08/49] Added support for custom redirect number in http requests --- basis/http/client/client.factor | 7 +++---- basis/http/client/debugger/debugger.factor | 2 +- basis/http/http-docs.factor | 1 + basis/http/http.factor | 8 ++++++-- 4 files changed, 11 insertions(+), 7 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 2f6bcfafe9..016e347e89 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -12,8 +12,6 @@ IN: http.client ERROR: too-many-redirects ; -CONSTANT: max-redirects 10 - > < [ request get clone response "location" header redirect-url response code>> 307 = [ "GET" >>method ] unless @@ -116,7 +114,8 @@ SYMBOL: redirects with-output-stream* ] [ in>> [ - read-response dup redirect? [ t ] [ + read-response dup redirect? + request get redirects>> 0 > and [ t ] [ [ nip response set ] [ read-response-body ] [ ] diff --git a/basis/http/client/debugger/debugger.factor b/basis/http/client/debugger/debugger.factor index 413ae7bd85..3688f38193 100644 --- a/basis/http/client/debugger/debugger.factor +++ b/basis/http/client/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel summary debugger io make math.parser -prettyprint http.client accessors ; +prettyprint http http.client accessors ; IN: http.client.debugger M: too-many-redirects summary diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index 210066176f..e7ff38ac42 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -17,6 +17,7 @@ $nl { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } } { { $slot "post-data" } { "See " { $link "http.post-data" } } } { { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } } + { { $slot "redirects" } { "Number of redirects to attempt before throwing an error. Default is " { $snippet "max-redirects" } " ." } } } } ; HELP: diff --git a/basis/http/http.factor b/basis/http/http.factor index 2b68edfb8e..4c32954eee 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -10,6 +10,8 @@ http.parsers base64 ; IN: http +CONSTANT: max-redirects 10 + : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] produce nip ; @@ -137,7 +139,8 @@ url version header post-data -cookies ; +cookies +redirects ; : set-header ( request/response value key -- request/response ) pick header>> set-at ; @@ -154,7 +157,8 @@ cookies ; H{ } clone >>header V{ } clone >>cookies "close" "connection" set-header - "Factor http.client" "user-agent" set-header ; + "Factor http.client" "user-agent" set-header + max-redirects >>redirects ; : header ( request/response key -- value ) swap header>> at ; From ded676e4e3c912704f9151a267bd07e8906466bf Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 22 Jun 2009 21:21:15 +0900 Subject: [PATCH 09/49] beginnings of extra/llvm --- extra/llvm/llvm-tests.factor | 0 extra/llvm/llvm.factor | 0 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 extra/llvm/llvm-tests.factor create mode 100644 extra/llvm/llvm.factor diff --git a/extra/llvm/llvm-tests.factor b/extra/llvm/llvm-tests.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/llvm/llvm.factor b/extra/llvm/llvm.factor new file mode 100644 index 0000000000..e69de29bb2 From 8934bb8e49803790a15b217904bc291e7e6b5c48 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 26 Jun 2009 00:21:54 +0900 Subject: [PATCH 10/49] Added type parser, factor llvm type objects, and recursive type resolution --- extra/llvm/core/core.factor | 85 ++++++++++++-- extra/llvm/llvm-tests.factor | 0 extra/llvm/llvm.factor | 0 extra/llvm/types/types-tests.factor | 20 ++++ extra/llvm/types/types.factor | 172 ++++++++++++++++++++++++++++ 5 files changed, 268 insertions(+), 9 deletions(-) delete mode 100644 extra/llvm/llvm-tests.factor delete mode 100644 extra/llvm/llvm.factor create mode 100644 extra/llvm/types/types-tests.factor create mode 100644 extra/llvm/types/types.factor diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor index 906364efeb..7b0f18bb17 100644 --- a/extra/llvm/core/core.factor +++ b/extra/llvm/core/core.factor @@ -115,6 +115,8 @@ TYPEDEF: void* LLVMModuleProviderRef TYPEDEF: void* LLVMTypeRef +TYPEDEF: void* LLVMTypeHandleRef + TYPEDEF: void* LLVMValueRef TYPEDEF: void* LLVMBasicBlockRef @@ -138,14 +140,79 @@ LLVMCreateModuleProviderForExistingModule ( LLVMModuleRef M ) ; FUNCTION: void LLVMDisposeModuleProvider ( LLVMModuleProviderRef MP ) ; -FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ; +! Types +! LLVM types conform to the following hierarchy: +! +! types: +! integer type +! real type +! function type +! sequence types: +! array type +! pointer type +! vector type +! void type +! label type +! opaque type + +! See llvm::LLVMTypeKind::getTypeID. +FUNCTION: LLVMTypeKind LLVMGetTypeKind ( LLVMTypeRef Ty ) ; + +! Operations on integer types +FUNCTION: LLVMTypeRef LLVMInt1Type ( ) ; +FUNCTION: LLVMTypeRef LLVMInt8Type ( ) ; +FUNCTION: LLVMTypeRef LLVMInt16Type ( ) ; +FUNCTION: LLVMTypeRef LLVMInt32Type ( ) ; +FUNCTION: LLVMTypeRef LLVMInt64Type ( ) ; +FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ; +FUNCTION: unsigned LLVMGetIntTypeWidth ( LLVMTypeRef IntegerTy ) ; + +! Operations on real types +FUNCTION: LLVMTypeRef LLVMFloatType ( ) ; +FUNCTION: LLVMTypeRef LLVMDoubleType ( ) ; +FUNCTION: LLVMTypeRef LLVMX86FP80Type ( ) ; +FUNCTION: LLVMTypeRef LLVMFP128Type ( ) ; +FUNCTION: LLVMTypeRef LLVMPPCFP128Type ( ) ; + +! Operations on function types FUNCTION: LLVMTypeRef -LLVMFunctionType ( LLVMTypeRef ReturnType, - LLVMTypeRef* ParamTypes, - unsigned ParamCount, - int IsVarArg ) ; - +LLVMFunctionType ( LLVMTypeRef ReturnType, LLVMTypeRef* ParamTypes, unsigned ParamCount, int IsVarArg ) ; +FUNCTION: int LLVMIsFunctionVarArg ( LLVMTypeRef FunctionTy ) ; +FUNCTION: LLVMTypeRef LLVMGetReturnType ( LLVMTypeRef FunctionTy ) ; +FUNCTION: unsigned LLVMCountParamTypes ( LLVMTypeRef FunctionTy ) ; +FUNCTION: void LLVMGetParamTypes ( LLVMTypeRef FunctionTy, LLVMTypeRef* Dest ) ; + +! Operations on struct types +FUNCTION: LLVMTypeRef +LLVMStructType ( LLVMTypeRef* ElementTypes, unsigned ElementCount, int Packed ) ; +FUNCTION: unsigned LLVMCountStructElementTypes ( LLVMTypeRef StructTy ) ; +FUNCTION: void LLVMGetStructElementTypes ( LLVMTypeRef StructTy, LLVMTypeRef* Dest ) ; +FUNCTION: int LLVMIsPackedStruct ( LLVMTypeRef StructTy ) ; + +! Operations on array, pointer, and vector types (sequence types) +FUNCTION: LLVMTypeRef LLVMArrayType ( LLVMTypeRef ElementType, unsigned ElementCount ) ; +FUNCTION: LLVMTypeRef LLVMPointerType ( LLVMTypeRef ElementType, unsigned AddressSpace ) ; +FUNCTION: LLVMTypeRef LLVMVectorType ( LLVMTypeRef ElementType, unsigned ElementCount ) ; + +FUNCTION: LLVMTypeRef LLVMGetElementType ( LLVMTypeRef Ty ) ; +FUNCTION: unsigned LLVMGetArrayLength ( LLVMTypeRef ArrayTy ) ; +FUNCTION: unsigned LLVMGetPointerAddressSpace ( LLVMTypeRef PointerTy ) ; +FUNCTION: unsigned LLVMGetVectorSize ( LLVMTypeRef VectorTy ) ; + +! Operations on other types +FUNCTION: LLVMTypeRef LLVMVoidType ( ) ; +FUNCTION: LLVMTypeRef LLVMLabelType ( ) ; +FUNCTION: LLVMTypeRef LLVMOpaqueType ( ) ; + +! Operations on type handles +FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy ) ; +FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy ) ; +FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle ) ; +FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle ) ; + +! Types end + FUNCTION: unsigned LLVMCountParams ( LLVMValueRef Fn ) ; FUNCTION: void LLVMGetParams ( LLVMValueRef Fn, LLVMValueRef* Params ) ; @@ -200,7 +267,7 @@ FUNCTION: LLVMValueRef LLVMBuildCondBr FUNCTION: LLVMValueRef LLVMBuildSwitch ( LLVMBuilderRef Builder, LLVMValueRef V, LLVMBasicBlockRef Else, unsigned NumCases ) ; FUNCTION: LLVMValueRef LLVMBuildInvoke -( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef *Args, unsigned NumArgs, +( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs, LLVMBasicBlockRef Then, LLVMBasicBlockRef Catch, char* Name ) ; FUNCTION: LLVMValueRef LLVMBuildUnwind ( LLVMBuilderRef Builder ) ; @@ -266,7 +333,7 @@ FUNCTION: LLVMValueRef LLVMBuildLoad FUNCTION: LLVMValueRef LLVMBuildStore ( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMValueRef Ptr ) ; FUNCTION: LLVMValueRef LLVMBuildGEP -( LLVMBuilderRef B, LLVMValueRef Pointer, LLVMValueRef *Indices, +( LLVMBuilderRef B, LLVMValueRef Pointer, LLVMValueRef* Indices, unsigned NumIndices, char* Name ) ; ! IB Casts @@ -308,7 +375,7 @@ FUNCTION: LLVMValueRef LLVMBuildFCmp FUNCTION: LLVMValueRef LLVMBuildPhi ( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ; FUNCTION: LLVMValueRef LLVMBuildCall -( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef *Args, unsigned NumArgs, char* Name ) ; +( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs, char* Name ) ; FUNCTION: LLVMValueRef LLVMBuildSelect ( LLVMBuilderRef Builder, LLVMValueRef If, LLVMValueRef Then, LLVMValueRef Else, char* Name ) ; FUNCTION: LLVMValueRef LLVMBuildVAArg diff --git a/extra/llvm/llvm-tests.factor b/extra/llvm/llvm-tests.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/extra/llvm/llvm.factor b/extra/llvm/llvm.factor deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/extra/llvm/types/types-tests.factor b/extra/llvm/types/types-tests.factor new file mode 100644 index 0000000000..8e9b9e2037 --- /dev/null +++ b/extra/llvm/types/types-tests.factor @@ -0,0 +1,20 @@ +USING: kernel llvm.types sequences tools.test ; + +[ T{ integer f 32 } ] [ " i32 " parse-type ] unit-test +[ float ] [ " float " parse-type ] unit-test +[ T{ pointer f f x86_fp80 } ] [ " x86_fp80 * " parse-type ] unit-test +[ T{ vector f f 4 T{ integer f 32 } } ] [ " < 4 x i32 > " parse-type ] unit-test +[ T{ struct f f { float double } f } ] [ TYPE: { float , double } ; ] unit-test +[ T{ array f f 0 float } ] [ TYPE: [ 0 x float ] ; ] unit-test + +[ label void metadata ] +[ [ " label " " void " " metadata " ] [ parse-type ] each ] unit-test + +[ T{ function f f float { float float } t } ] +[ TYPE: float ( float , float , ... ) ; ] unit-test + +[ T{ struct f f { float TYPE: i32 (i32)* ; } t } ] +[ TYPE: < { float, i32 (i32)* } > ; ] unit-test + +[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test +[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test \ No newline at end of file diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor new file mode 100644 index 0000000000..91210af83d --- /dev/null +++ b/extra/llvm/types/types.factor @@ -0,0 +1,172 @@ +USING: accessors arrays combinators kernel llvm.core +locals math.parser math multiline +namespaces parser peg.ebnf sequences +sequences.deep specialized-arrays.alien strings vocabs words ; + +IN: llvm.types + +! Type resolution strategy: +! pass 1: +! create the type with uprefs mapped to opaque types +! cache typerefs in enclosing types for pass 2 +! if our type is concrete, then we are done +! +! pass 2: +! wrap our abstract type in a type handle +! create a second type, using the cached enclosing type info +! resolve the first type to the second +! +GENERIC: (>tref) ( type -- LLVMTypeRef ) + +GENERIC: llvm> ( LLVMTypeRef -- type ) + +TUPLE: integer size ; +C: integer + +M: integer (>tref) size>> LLVMIntType ; + +SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ; + +M: float (>tref) drop LLVMFloatType ; +M: double (>tref) drop LLVMDoubleType ; +M: x86_fp80 (>tref) drop LLVMX86FP80Type ; +M: fp128 (>tref) drop LLVMFP128Type ; +M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ; + +SINGLETONS: label void metadata ; + +M: label (>tref) drop LLVMLabelType ; +M: void (>tref) drop LLVMVoidType ; +M: metadata (>tref) drop + "metadata types unsupported by llvm c bindings" throw ; + +! enclosing types cache their llvm refs during +! the first pass, used in the second pass to +! resolve uprefs +TUPLE: enclosing cached ; + +GENERIC: clean ( type -- ) +GENERIC: clean* ( type -- ) +M: object clean drop ; +M: enclosing clean f >>cached clean* ; + +! builds the stack of types that uprefs need to refer to +SYMBOL: types +:: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef ) + type types get push + type quot call( type -- LLVMTypeRef ) + types get pop over >>cached drop ; + +GENERIC: (>tref)* ( type -- LLVMTypeRef ) +M: enclosing (>tref) [ (>tref)* ] push-type ; + +TUPLE: pointer < enclosing type ; +: ( t -- o ) pointer new swap >>type ; + +M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ; +M: pointer clean* type>> clean ; + +TUPLE: vector < enclosing size type ; +: ( s t -- o ) + vector new + swap >>type swap >>size ; + +M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ; +M: vector clean* type>> clean ; + +TUPLE: struct < enclosing types packed? ; +: ( ts p? -- o ) + struct new + swap >>packed? swap >>types ; + +M: struct (>tref)* + [ types>> [ (>tref) ] map >void*-array ] + [ types>> length ] + [ packed?>> 1 0 ? ] tri LLVMStructType ; +M: struct clean* types>> [ clean ] each ; + +TUPLE: array < enclosing size type ; +: ( s t -- o ) + array new + swap >>type swap >>size ; + +M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ; +M: array clean* type>> clean ; + +SYMBOL: ... +TUPLE: function < enclosing return params vararg? ; +: ( ret params var? -- o ) + function new + swap >>vararg? swap >>params swap >>return ; + +M: function (>tref)* { + [ return>> (>tref) ] + [ params>> [ (>tref) ] map >void*-array ] + [ params>> length ] + [ vararg?>> 1 0 ? ] +} cleave LLVMFunctionType ; +M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ; + +TUPLE: up-ref height ; +C: up-ref + +M: up-ref (>tref) + types get length swap height>> - types get nth + cached>> [ LLVMOpaqueType ] unless* ; + +: resolve-types ( typeref typeref -- typeref ) + over LLVMCreateTypeHandle [ LLVMRefineType ] dip + [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ; + +: >tref-caching ( type -- LLVMTypeRef ) + V{ } clone types [ (>tref) ] with-variable ; + +: >tref ( type -- LLVMTypeRef ) + [ >tref-caching ] [ >tref-caching ] [ clean ] tri + 2dup = [ drop ] [ resolve-types ] if ; + +: t. ( type -- ) + >tref + "type-info" LLVMModuleCreateWithName + [ "t" rot LLVMAddTypeName drop ] + [ LLVMDumpModule ] + [ LLVMDisposeModule ] tri ; + +EBNF: parse-type + +WhiteSpace = " "* + +Zero = "0" => [[ drop 0 ]] +LeadingDigit = [1-9] +DecimalDigit = [0-9] +Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]] +WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]] +WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]] + +Integer = "i" Number:n => [[ n ]] +FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]] +LabelVoidMetadata = ( "label" | "void" | "metadata" ) => [[ "llvm.types" vocab lookup ]] +Primitive = LabelVoidMetadata | FloatingPoint +Pointer = T:t WhiteSpace "*" => [[ t ]] +Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t ]] +StructureTypesList = "," Type:t => [[ t ]] +Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f ]] +Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t ]] +NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]] +VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]] +ParamListContinued = "," (Type | VarArgs):t => [[ t ]] +ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]] +Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot ]] +PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t ]] +UpReference = "\\" Number:n => [[ n ]] +Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]] + +T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name + +Type = WhiteSpace T:t WhiteSpace => [[ t ]] + +Program = Type + +;EBNF + +SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ; \ No newline at end of file From c331b310077ec0ab0993b186fc6e46802886e9b7 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 26 Jun 2009 22:00:55 +0900 Subject: [PATCH 11/49] Update LLVMTypeKind enum --- extra/llvm/core/core.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor index 7b0f18bb17..d4002d719a 100644 --- a/extra/llvm/core/core.factor +++ b/extra/llvm/core/core.factor @@ -40,6 +40,7 @@ C-ENUM: LLVMFP128TypeKind LLVMPPC_FP128TypeKind LLVMLabelTypeKind + LLVMMetadataTypeKind LLVMIntegerTypeKind LLVMFunctionTypeKind LLVMStructTypeKind From 081f24ccf7ce51d508d4320211ca49b322b8d4c3 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 26 Jun 2009 22:01:20 +0900 Subject: [PATCH 12/49] convert from LLVM types, with tests --- extra/llvm/types/types-tests.factor | 20 ++++++++- extra/llvm/types/types.factor | 64 +++++++++++++++++++++++++++-- 2 files changed, 80 insertions(+), 4 deletions(-) diff --git a/extra/llvm/types/types-tests.factor b/extra/llvm/types/types-tests.factor index 8e9b9e2037..d38dbf1d5b 100644 --- a/extra/llvm/types/types-tests.factor +++ b/extra/llvm/types/types-tests.factor @@ -17,4 +17,22 @@ USING: kernel llvm.types sequences tools.test ; [ TYPE: < { float, i32 (i32)* } > ; ] unit-test [ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test -[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test \ No newline at end of file +[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test + +[ TYPE: i32 ; ] [ TYPE: i32 ; >tref tref> ] unit-test +[ TYPE: float ; ] [ TYPE: float ; >tref tref> ] unit-test +[ TYPE: double ; ] [ TYPE: double ; >tref tref> ] unit-test +[ TYPE: x86_fp80 ; ] [ TYPE: x86_fp80 ; >tref tref> ] unit-test +[ TYPE: fp128 ; ] [ TYPE: fp128 ; >tref tref> ] unit-test +[ TYPE: ppc_fp128 ; ] [ TYPE: ppc_fp128 ; >tref tref> ] unit-test +[ TYPE: opaque ; ] [ TYPE: opaque ; >tref tref> ] unit-test +[ TYPE: label ; ] [ TYPE: label ; >tref tref> ] unit-test +[ TYPE: void ; ] [ TYPE: void ; >tref tref> ] unit-test +[ TYPE: i32* ; ] [ TYPE: i32* ; >tref tref> ] unit-test +[ TYPE: < 2 x i32 > ; ] [ TYPE: < 2 x i32 > ; >tref tref> ] unit-test +[ TYPE: [ 0 x i32 ] ; ] [ TYPE: [ 0 x i32 ] ; >tref tref> ] unit-test +[ TYPE: { i32, i32 } ; ] [ TYPE: { i32, i32 } ; >tref tref> ] unit-test +[ TYPE: < { i32, i32 } > ; ] [ TYPE: < { i32, i32 } > ; >tref tref> ] unit-test +[ TYPE: i32 ( i32 ) ; ] [ TYPE: i32 ( i32 ) ; >tref tref> ] unit-test +[ TYPE: \1* ; ] [ TYPE: \1* ; >tref tref> ] unit-test +[ TYPE: { i32, \2* } ; ] [ TYPE: { i32, \2* } ; >tref tref> ] unit-test \ No newline at end of file diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor index 91210af83d..1d528fb699 100644 --- a/extra/llvm/types/types.factor +++ b/extra/llvm/types/types.factor @@ -17,13 +17,16 @@ IN: llvm.types ! resolve the first type to the second ! GENERIC: (>tref) ( type -- LLVMTypeRef ) +GENERIC: ((tref>)) ( LLVMTypeRef type -- type ) -GENERIC: llvm> ( LLVMTypeRef -- type ) +! default implementation for simple types +M: object ((tref>)) nip ; TUPLE: integer size ; C: integer M: integer (>tref) size>> LLVMIntType ; +M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ; SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ; @@ -33,8 +36,9 @@ M: x86_fp80 (>tref) drop LLVMX86FP80Type ; M: fp128 (>tref) drop LLVMFP128Type ; M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ; -SINGLETONS: label void metadata ; +SINGLETONS: opaque label void metadata ; +M: opaque (>tref) drop LLVMOpaqueType ; M: label (>tref) drop LLVMLabelType ; M: void (>tref) drop LLVMVoidType ; M: metadata (>tref) drop @@ -57,14 +61,30 @@ SYMBOL: types type quot call( type -- LLVMTypeRef ) types get pop over >>cached drop ; +DEFER: +:: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type ) + ref types get index + [ types get length swap - ] [ + ref types get push + ref quot call( LLVMTypeRef -- type ) + types get pop drop + ] if* ; + GENERIC: (>tref)* ( type -- LLVMTypeRef ) M: enclosing (>tref) [ (>tref)* ] push-type ; +DEFER: type-kind +GENERIC: (tref>)* ( LLVMTypeRef type -- type ) +M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ; + +: (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ; + TUPLE: pointer < enclosing type ; : ( t -- o ) pointer new swap >>type ; M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ; M: pointer clean* type>> clean ; +M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ; TUPLE: vector < enclosing size type ; : ( s t -- o ) @@ -73,6 +93,9 @@ TUPLE: vector < enclosing size type ; M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ; M: vector clean* type>> clean ; +M: vector (tref>)* + over LLVMGetElementType (tref>) >>type + swap LLVMGetVectorSize >>size ; TUPLE: struct < enclosing types packed? ; : ( ts p? -- o ) @@ -84,6 +107,11 @@ M: struct (>tref)* [ types>> length ] [ packed?>> 1 0 ? ] tri LLVMStructType ; M: struct clean* types>> [ clean ] each ; +M: struct (tref>)* + over LLVMIsPackedStruct 0 = not >>packed? + swap dup LLVMCountStructElementTypes + [ LLVMGetStructElementTypes ] keep >array + [ (tref>) ] map >>types ; TUPLE: array < enclosing size type ; : ( s t -- o ) @@ -92,6 +120,9 @@ TUPLE: array < enclosing size type ; M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ; M: array clean* type>> clean ; +M: array (tref>)* + over LLVMGetElementType (tref>) >>type + swap LLVMGetArrayLength >>size ; SYMBOL: ... TUPLE: function < enclosing return params vararg? ; @@ -106,6 +137,30 @@ M: function (>tref)* { [ vararg?>> 1 0 ? ] } cleave LLVMFunctionType ; M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ; +M: function (tref>)* + over LLVMIsFunctionVarArg 0 = not >>vararg? + over LLVMGetReturnType (tref>) >>return + swap dup LLVMCountParamTypes + [ LLVMGetParamTypes ] keep >array + [ (tref>) ] map >>params ; + +: type-kind ( LLVMTypeRef -- class ) + LLVMGetTypeKind { + { LLVMVoidTypeKind [ void ] } + { LLVMFloatTypeKind [ float ] } + { LLVMDoubleTypeKind [ double ] } + { LLVMX86_FP80TypeKind [ x86_fp80 ] } + { LLVMFP128TypeKind [ fp128 ] } + { LLVMPPC_FP128TypeKind [ ppc_fp128 ] } + { LLVMLabelTypeKind [ label ] } + { LLVMIntegerTypeKind [ integer new ] } + { LLVMFunctionTypeKind [ function new ] } + { LLVMStructTypeKind [ struct new ] } + { LLVMArrayTypeKind [ array new ] } + { LLVMPointerTypeKind [ pointer new ] } + { LLVMOpaqueTypeKind [ opaque ] } + { LLVMVectorTypeKind [ vector new ] } + } case ; TUPLE: up-ref height ; C: up-ref @@ -125,6 +180,9 @@ M: up-ref (>tref) [ >tref-caching ] [ >tref-caching ] [ clean ] tri 2dup = [ drop ] [ resolve-types ] if ; +: tref> ( LLVMTypeRef -- type ) + V{ } clone types [ (tref>) ] with-variable ; + : t. ( type -- ) >tref "type-info" LLVMModuleCreateWithName @@ -145,7 +203,7 @@ WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]] Integer = "i" Number:n => [[ n ]] FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]] -LabelVoidMetadata = ( "label" | "void" | "metadata" ) => [[ "llvm.types" vocab lookup ]] +LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup ]] Primitive = LabelVoidMetadata | FloatingPoint Pointer = T:t WhiteSpace "*" => [[ t ]] Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t ]] From 48863ca17100a6a53eb1e5bc32f5fbf09dae88ae Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 27 Jun 2009 18:41:40 +0900 Subject: [PATCH 13/49] Added global jit, and convenience words for dealing with it --- extra/llvm/core/core.factor | 4 ++ extra/llvm/engine/engine.factor | 7 ++++ extra/llvm/jit/jit-tests.factor | 3 ++ extra/llvm/jit/jit.factor | 45 +++++++++++++++++++++ extra/llvm/wrappers/wrappers-tests.factor | 5 +++ extra/llvm/wrappers/wrappers.factor | 48 +++++++++++++++++++++++ 6 files changed, 112 insertions(+) create mode 100644 extra/llvm/jit/jit-tests.factor create mode 100644 extra/llvm/jit/jit.factor create mode 100644 extra/llvm/wrappers/wrappers-tests.factor create mode 100644 extra/llvm/wrappers/wrappers.factor diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor index d4002d719a..292a25b80b 100644 --- a/extra/llvm/core/core.factor +++ b/extra/llvm/core/core.factor @@ -221,6 +221,10 @@ FUNCTION: void LLVMGetParams ( LLVMValueRef Fn, LLVMValueRef* Params ) ; FUNCTION: LLVMValueRef LLVMAddFunction ( LLVMModuleRef M, char* Name, LLVMTypeRef FunctionTy ) ; +FUNCTION: LLVMValueRef LLVMGetFirstFunction ( LLVMModuleRef M ) ; + +FUNCTION: LLVMValueRef LLVMGetNextFunction ( LLVMValueRef Fn ) ; + FUNCTION: unsigned LLVMGetFunctionCallConv ( LLVMValueRef Fn ) ; FUNCTION: void LLVMSetFunctionCallConv ( LLVMValueRef Fn, unsigned CC ) ; diff --git a/extra/llvm/engine/engine.factor b/extra/llvm/engine/engine.factor index db5c7014ef..ad51d02785 100644 --- a/extra/llvm/engine/engine.factor +++ b/extra/llvm/engine/engine.factor @@ -50,6 +50,13 @@ FUNCTION: int LLVMCreateJITCompiler FUNCTION: void LLVMDisposeExecutionEngine ( LLVMExecutionEngineRef EE ) ; +FUNCTION: void LLVMFreeMachineCodeForFunction ( LLVMExecutionEngineRef EE, LLVMValueRef F ) ; + +FUNCTION: void LLVMAddModuleProvider ( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP ) ; + +FUNCTION: int LLVMRemoveModuleProvider +( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP, LLVMModuleRef* OutMod, char** OutError ) ; + FUNCTION: int LLVMFindFunction ( LLVMExecutionEngineRef EE, char* Name, LLVMValueRef* OutFn ) ; diff --git a/extra/llvm/jit/jit-tests.factor b/extra/llvm/jit/jit-tests.factor new file mode 100644 index 0000000000..5a894e5a50 --- /dev/null +++ b/extra/llvm/jit/jit-tests.factor @@ -0,0 +1,3 @@ +USING: destructors llvm.jit llvm.wrappers tools.test ; + +[ ] [ "test" [ ] with-disposal [ "test" add-provider ] with-disposal "test" remove-provider ] unit-test \ No newline at end of file diff --git a/extra/llvm/jit/jit.factor b/extra/llvm/jit/jit.factor new file mode 100644 index 0000000000..5a85742619 --- /dev/null +++ b/extra/llvm/jit/jit.factor @@ -0,0 +1,45 @@ +USING: accessors alien.c-types alien.syntax assocs destructors +kernel llvm.core llvm.engine llvm.wrappers namespaces ; + +IN: llvm.jit + +SYMBOL: thejit + +TUPLE: jit ee mps ; + +: empty-engine ( -- engine ) + "initial-module" [ + + ] with-disposal [ + + ] with-disposal ; + +: ( -- jit ) + jit new empty-engine >>ee H{ } clone >>mps ; + +: (remove-functions) ( function -- ) + thejit get ee>> value>> over LLVMFreeMachineCodeForFunction + LLVMGetNextFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ; + +: remove-functions ( module -- ) + ! free machine code for each function in module + LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ; + +: (remove-provider) ( provider -- ) + thejit get ee>> value>> swap value>> f f + [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when* + *void* module new swap >>value + [ value>> remove-functions ] with-disposal ; + +: remove-provider ( name -- ) + dup thejit get mps>> at [ + (remove-provider) + thejit get mps>> delete-at + ] [ drop ] if* ; + +: add-provider ( provider name -- ) + dup remove-provider + thejit get ee>> value>> pick value>> LLVMAddModuleProvider + [ t >>disposed ] dip thejit get mps>> set-at ; + +thejit [ ] initialize \ No newline at end of file diff --git a/extra/llvm/wrappers/wrappers-tests.factor b/extra/llvm/wrappers/wrappers-tests.factor new file mode 100644 index 0000000000..fe90184a5d --- /dev/null +++ b/extra/llvm/wrappers/wrappers-tests.factor @@ -0,0 +1,5 @@ +USING: destructors kernel llvm.wrappers sequences tools.test vocabs ; + +[ ] [ "test" dispose ] unit-test +[ ] [ "test" [ ] with-disposal dispose ] unit-test +[ ] [ "llvm.jit" vocabs member? [ "test" [ ] with-disposal [ ] with-disposal dispose ] unless ] unit-test \ No newline at end of file diff --git a/extra/llvm/wrappers/wrappers.factor b/extra/llvm/wrappers/wrappers.factor new file mode 100644 index 0000000000..2a3e696edc --- /dev/null +++ b/extra/llvm/wrappers/wrappers.factor @@ -0,0 +1,48 @@ +USING: accessors alien.c-types alien.strings destructors kernel +llvm.core llvm.engine ; + +IN: llvm.wrappers + +: llvm-throw ( char* -- ) + [ alien>string ] [ LLVMDisposeMessage ] bi throw ; + +: ( alien class -- disposable ) new swap >>value ; + +TUPLE: module value disposed ; +M: module dispose* value>> LLVMDisposeModule ; + +: ( name -- module ) + LLVMModuleCreateWithName module ; + +TUPLE: provider value disposed ; +M: provider dispose* value>> LLVMDisposeModuleProvider ; + +: ( module -- module-provider ) + ! we don't want to dispose when an error occurs + ! for example, retries with the same module wouldn't work + ! but we do want to mark the module as disposed on success + [ value>> LLVMCreateModuleProviderForExistingModule ] + [ t >>disposed drop ] bi + provider ; + +TUPLE: engine value disposed ; +M: engine dispose* value>> LLVMDisposeExecutionEngine ; + +: ( provider -- engine ) + [ + value>> f f + [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep + *void* [ llvm-throw ] when* *void* + ] + [ t >>disposed drop ] bi + engine ; + +: (add-block) ( name -- basic-block ) + "function" swap LLVMAppendBasicBlock ; + +TUPLE: builder value disposed ; +M: builder dispose* value>> LLVMDisposeBuilder ; + +: ( name -- builder ) + (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep + builder ; \ No newline at end of file From c843edd87003c2e823b114df199552681dac7733 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 30 Jun 2009 11:43:04 +0900 Subject: [PATCH 14/49] install functions from llvm bytecode, with test --- extra/llvm/core/core.factor | 21 ++++++++- extra/llvm/invoker/invoker.factor | 54 ++++++++++++++++++++++ extra/llvm/jit/jit-tests.factor | 2 +- extra/llvm/jit/jit.factor | 26 ++++++----- extra/llvm/reader/add.bc | Bin 0 -> 204 bytes extra/llvm/reader/add.ll | 5 ++ extra/llvm/reader/reader.factor | 18 ++++++++ extra/llvm/wrappers/wrappers-tests.factor | 4 +- extra/llvm/wrappers/wrappers.factor | 36 ++++++++++----- 9 files changed, 138 insertions(+), 28 deletions(-) create mode 100644 extra/llvm/invoker/invoker.factor create mode 100644 extra/llvm/reader/add.bc create mode 100644 extra/llvm/reader/add.ll create mode 100644 extra/llvm/reader/reader.factor diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor index 292a25b80b..f63927455a 100644 --- a/extra/llvm/core/core.factor +++ b/extra/llvm/core/core.factor @@ -10,6 +10,8 @@ IN: llvm.core "LLVMCore" "/usr/local/lib/libLLVMCore.dylib" "cdecl" add-library +"LLVMBitReader" "/usr/local/lib/libLLVMBitReader.dylib" "cdecl" add-library + >> ! llvm-c/Core.h @@ -124,9 +126,11 @@ TYPEDEF: void* LLVMBasicBlockRef TYPEDEF: void* LLVMBuilderRef +TYPEDEF: void* LLVMMemoryBufferRef + ! Functions -FUNCTION: void LLVMDisposeMessage ( char *Message ) ; +FUNCTION: void LLVMDisposeMessage ( char* Message ) ; FUNCTION: LLVMModuleRef LLVMModuleCreateWithName ( char* ModuleID ) ; @@ -395,3 +399,18 @@ FUNCTION: LLVMValueRef LLVMBuildExtractValue ( LLVMBuilderRef Builder, LLVMValueRef AggVal, unsigned Index, char* Name ) ; FUNCTION: LLVMValueRef LLVMBuildInsertValue ( LLVMBuilderRef Builder, LLVMValueRef AggVal, LLVMValueRef EltVal, unsigned Index, char* Name ) ; + +! Memory Buffers/Bit Reader + +FUNCTION: int LLVMCreateMemoryBufferWithContentsOfFile +( char* Path, LLVMMemoryBufferRef* OutMemBuf, char** OutMessage ) ; + +FUNCTION: void LLVMDisposeMemoryBuffer ( LLVMMemoryBufferRef MemBuf ) ; + +LIBRARY: LLVMBitReader + +FUNCTION: int LLVMParseBitcode +( LLVMMemoryBufferRef MemBuf, LLVMModuleRef* OutModule, char** OutMessage ) ; + +FUNCTION: int LLVMGetBitcodeModuleProvider +( LLVMMemoryBufferRef MemBuf, LLVMModuleProviderRef* OutMP, char** OutMessage ) ; diff --git a/extra/llvm/invoker/invoker.factor b/extra/llvm/invoker/invoker.factor new file mode 100644 index 0000000000..55ebe6db84 --- /dev/null +++ b/extra/llvm/invoker/invoker.factor @@ -0,0 +1,54 @@ +USING: accessors alien arrays assocs compiler.units effects +io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader +llvm.types make namespaces sequences specialized-arrays.alien +vocabs words ; + +IN: llvm.invoker + +! get function name, ret type, param types and names + +! load module +! iterate through functions in a module + +TUPLE: function name alien return params ; + +: params ( llvm-function -- param-list ) + dup LLVMCountParams + [ LLVMGetParams ] keep >array + [ [ LLVMGetValueName ] [ LLVMTypeOf tref> ] bi 2array ] map ; + +: ( LLVMValueRef -- function ) + function new + over LLVMGetValueName >>name + over LLVMTypeOf tref> type>> return>> >>return + swap params >>params ; + +: (functions) ( llvm-function -- ) + [ dup , LLVMGetNextFunction (functions) ] when* ; + +: functions ( llvm-module -- functions ) + LLVMGetFirstFunction [ (functions) ] { } make [ ] map ; + +: function-effect ( function -- effect ) + [ params>> [ first ] map ] [ void? 0 1 ? ] bi ; + +: install-function ( function -- ) + dup name>> "alien.llvm" create-vocab drop + "alien.llvm" create swap + [ + dup name>> function-pointer , + dup return>> drop "int" , + dup params>> [ drop "int" ] map , + "cdecl" , \ alien-indirect , + ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ; + +: install-module ( name -- ) + thejit get mps>> at [ + module>> functions [ install-function ] each + ] [ "no such module" throw ] if* ; + +: install-bc ( path -- ) + [ normalize-path ] [ file-name ] bi + [ load-into-jit ] keep install-module ; + +<< "alien.llvm" create-vocab drop >> \ No newline at end of file diff --git a/extra/llvm/jit/jit-tests.factor b/extra/llvm/jit/jit-tests.factor index 5a894e5a50..9808ecb953 100644 --- a/extra/llvm/jit/jit-tests.factor +++ b/extra/llvm/jit/jit-tests.factor @@ -1,3 +1,3 @@ USING: destructors llvm.jit llvm.wrappers tools.test ; -[ ] [ "test" [ ] with-disposal [ "test" add-provider ] with-disposal "test" remove-provider ] unit-test \ No newline at end of file +[ ] [ "test" "test" add-module "test" remove-module ] unit-test \ No newline at end of file diff --git a/extra/llvm/jit/jit.factor b/extra/llvm/jit/jit.factor index 5a85742619..9281b609e3 100644 --- a/extra/llvm/jit/jit.factor +++ b/extra/llvm/jit/jit.factor @@ -8,11 +8,7 @@ SYMBOL: thejit TUPLE: jit ee mps ; : empty-engine ( -- engine ) - "initial-module" [ - - ] with-disposal [ - - ] with-disposal ; + "initial-module" ; : ( -- jit ) jit new empty-engine >>ee H{ } clone >>mps ; @@ -25,21 +21,27 @@ TUPLE: jit ee mps ; ! free machine code for each function in module LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ; -: (remove-provider) ( provider -- ) +: remove-provider ( provider -- ) thejit get ee>> value>> swap value>> f f [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when* *void* module new swap >>value [ value>> remove-functions ] with-disposal ; -: remove-provider ( name -- ) +: remove-module ( name -- ) dup thejit get mps>> at [ - (remove-provider) + remove-provider thejit get mps>> delete-at ] [ drop ] if* ; -: add-provider ( provider name -- ) - dup remove-provider - thejit get ee>> value>> pick value>> LLVMAddModuleProvider - [ t >>disposed ] dip thejit get mps>> set-at ; +: add-module ( module name -- ) + [ ] dip [ remove-module ] keep + thejit get ee>> value>> pick + [ [ value>> LLVMAddModuleProvider ] [ t >>disposed drop ] bi ] with-disposal + thejit get mps>> set-at ; + +: function-pointer ( name -- alien ) + thejit get ee>> value>> dup + rot f [ LLVMFindFunction drop ] keep + *void* LLVMGetPointerToGlobal ; thejit [ ] initialize \ No newline at end of file diff --git a/extra/llvm/reader/add.bc b/extra/llvm/reader/add.bc new file mode 100644 index 0000000000000000000000000000000000000000..c0ba738d25855ef9cd68b1504e8c1fc8b061c9ca GIT binary patch literal 204 zcmZ>AK5$Qwhk?O>fq{WhfPn#s7}y(?Cpw;B@njP)vYf=&!lTN{At}ewoz%eN%H%YO z+bKoBNW_9e!jsF$Ma6?_f}*lZQ9}=pVjEW%R|=0j14Ez!0|O_}93!O@915vTEevYT z9;}>d&c|4tjMO+fESU@xrZOJj0IFbMaGnIF7!-I|7`T8;VHQVLrUwFiEI>9Z5Stlz kh$J%}Ol4v$V_?1LBgh6(&QPepz`z7#vl%cPh6*tN01Zmodule ( buffer -- module ) + [ + value>> f f + [ LLVMParseBitcode drop ] 2keep + *void* [ llvm-throw ] when* *void* + module new swap >>value + ] with-disposal ; + +: load-module ( path -- module ) + buffer>module ; + +: load-into-jit ( path name -- ) + [ load-module ] dip add-module ; \ No newline at end of file diff --git a/extra/llvm/wrappers/wrappers-tests.factor b/extra/llvm/wrappers/wrappers-tests.factor index fe90184a5d..321762e2cf 100644 --- a/extra/llvm/wrappers/wrappers-tests.factor +++ b/extra/llvm/wrappers/wrappers-tests.factor @@ -1,5 +1,5 @@ USING: destructors kernel llvm.wrappers sequences tools.test vocabs ; [ ] [ "test" dispose ] unit-test -[ ] [ "test" [ ] with-disposal dispose ] unit-test -[ ] [ "llvm.jit" vocabs member? [ "test" [ ] with-disposal [ ] with-disposal dispose ] unless ] unit-test \ No newline at end of file +[ ] [ "test" dispose ] unit-test +[ ] [ "llvm.jit" vocabs member? [ "test" dispose ] unless ] unit-test \ No newline at end of file diff --git a/extra/llvm/wrappers/wrappers.factor b/extra/llvm/wrappers/wrappers.factor index 2a3e696edc..22da1b36f4 100644 --- a/extra/llvm/wrappers/wrappers.factor +++ b/extra/llvm/wrappers/wrappers.factor @@ -1,10 +1,11 @@ -USING: accessors alien.c-types alien.strings destructors kernel +USING: accessors alien.c-types alien.strings +io.encodings.utf8 destructors kernel llvm.core llvm.engine ; IN: llvm.wrappers : llvm-throw ( char* -- ) - [ alien>string ] [ LLVMDisposeMessage ] bi throw ; + [ utf8 alien>string ] [ LLVMDisposeMessage ] bi throw ; : ( alien class -- disposable ) new swap >>value ; @@ -14,21 +15,21 @@ M: module dispose* value>> LLVMDisposeModule ; : ( name -- module ) LLVMModuleCreateWithName module ; -TUPLE: provider value disposed ; +TUPLE: provider value module disposed ; M: provider dispose* value>> LLVMDisposeModuleProvider ; -: ( module -- module-provider ) - ! we don't want to dispose when an error occurs - ! for example, retries with the same module wouldn't work - ! but we do want to mark the module as disposed on success - [ value>> LLVMCreateModuleProviderForExistingModule ] - [ t >>disposed drop ] bi - provider ; +: (provider) ( module -- provider ) + [ value>> LLVMCreateModuleProviderForExistingModule provider ] + [ t >>disposed value>> ] bi + >>module ; + +: ( module -- provider ) + [ (provider) ] with-disposal ; TUPLE: engine value disposed ; M: engine dispose* value>> LLVMDisposeExecutionEngine ; -: ( provider -- engine ) +: (engine) ( provider -- engine ) [ value>> f f [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep @@ -37,6 +38,9 @@ M: engine dispose* value>> LLVMDisposeExecutionEngine ; [ t >>disposed drop ] bi engine ; +: ( provider -- engine ) + [ (engine) ] with-disposal ; + : (add-block) ( name -- basic-block ) "function" swap LLVMAppendBasicBlock ; @@ -45,4 +49,12 @@ M: builder dispose* value>> LLVMDisposeBuilder ; : ( name -- builder ) (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep - builder ; \ No newline at end of file + builder ; + +TUPLE: buffer value disposed ; +M: buffer dispose* value>> LLVMDisposeMemoryBuffer ; + +: ( path -- module ) + f f + [ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep + *void* [ llvm-throw ] when* *void* buffer ; \ No newline at end of file From 1716a4bec8bf8b76852aa49761b542959561ff3e Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 30 Jun 2009 11:57:24 +0900 Subject: [PATCH 15/49] remove llvm.bindings, made obsolete by llvm.wrappers and friends --- extra/llvm/bindings/bindings-tests.factor | 32 --------- extra/llvm/bindings/bindings.factor | 79 ----------------------- 2 files changed, 111 deletions(-) delete mode 100644 extra/llvm/bindings/bindings-tests.factor delete mode 100644 extra/llvm/bindings/bindings.factor diff --git a/extra/llvm/bindings/bindings-tests.factor b/extra/llvm/bindings/bindings-tests.factor deleted file mode 100644 index 59eaf270f9..0000000000 --- a/extra/llvm/bindings/bindings-tests.factor +++ /dev/null @@ -1,32 +0,0 @@ -USING: accessors alien compiler.units kernel -llvm.bindings llvm.core tools.test words ; - -IN: scratchpad - -: add-abi ( x y -- x+y ) ! to be filled in by llvm - drop ; - -: llvm-add ( x y -- x+y ) - "test" [ - { - { [ 32 LLVMIntType ] "add" } - { [ 32 LLVMIntType ] "x" } - { [ 32 LLVMIntType ] "y" } - } [ - "entry" [ - builder value>> "x" get-param "y" get-param "sum" LLVMBuildAdd - builder value>> swap LLVMBuildRet drop - ] with-builder - ] with-function - - - ] with-module - - [ - "add" find-function global>pointer - [ "int" { "int" "int" } "cdecl" alien-indirect ] curry \ add-abi swap - (( x y -- x+y )) [ define-declared ] with-compilation-unit - add-abi ! call our new word - ] with-engine ; inline - -[ 7 ] [ 3 4 llvm-add ] unit-test \ No newline at end of file diff --git a/extra/llvm/bindings/bindings.factor b/extra/llvm/bindings/bindings.factor deleted file mode 100644 index 390b55aa37..0000000000 --- a/extra/llvm/bindings/bindings.factor +++ /dev/null @@ -1,79 +0,0 @@ -USING: accessors alien.c-types alien.strings arrays -central destructors kernel llvm.core llvm.engine -quotations sequences specialized-arrays.alien ; - -IN: llvm.bindings - -: llvm-throw ( char** -- ) - [ alien>string ] [ LLVMDisposeMessage ] bi throw ; - -DISPOSABLE-CENTRAL: module -CENTRAL: function -DISPOSABLE-CENTRAL: builder -DISPOSABLE-CENTRAL: engine - -: ( alien class -- disposable ) new swap >>value ; - -TUPLE: LLVMModule value disposed ; -M: LLVMModule dispose* value>> LLVMDisposeModule ; - -: ( name -- module ) - LLVMModuleCreateWithName LLVMModule ; - -TUPLE: LLVMModuleProvider value disposed ; -M: LLVMModuleProvider dispose* value>> LLVMDisposeModuleProvider ; - -: ( -- module-provider ) - module t >>disposed value>> LLVMCreateModuleProviderForExistingModule - LLVMModuleProvider ; - -: (add-block) ( name -- basic-block ) - function swap LLVMAppendBasicBlock ; - -TUPLE: LLVMBuilder value disposed ; -M: LLVMBuilder dispose* value>> LLVMDisposeBuilder ; - -: ( name -- builder ) - (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep - LLVMBuilder ; - -TUPLE: LLVMExecutionEngine value disposed ; -M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ; - -: ( -- engine ) - [ - dup value>> f f - [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep - *void* [ llvm-throw ] when* *void* LLVMExecutionEngine - swap t >>disposed drop - ] with-disposal ; - -: resolve-type ( callable/alien -- type ) - dup callable? [ call( -- type ) ] when ; - -: ( args -- type ) - [ resolve-type ] map - unclip swap [ >void*-array ] keep length 0 LLVMFunctionType ; - -: >>cc ( function calling-convention -- function ) - dupd LLVMSetFunctionCallConv ; - -: params>> ( function -- array ) - dup LLVMCountParams "LLVMValueRef" [ LLVMGetParams ] keep - byte-array>void*-array >array ; - -: get-param ( name -- value ) - function params>> swap [ swap LLVMGetValueName = ] curry find nip ; - -: set-param-names ( names function -- ) - params>> swap [ LLVMSetValueName ] 2each ; - -: ( args -- function ) - module value>> over first second pick - [ first ] map LLVMAddFunction LLVMCCallConv >>cc tuck - [ rest [ second ] map ] dip set-param-names ; - -: global>pointer ( value -- alien ) engine value>> swap LLVMGetPointerToGlobal ; - -: find-function ( name -- fn ) - engine value>> swap f [ LLVMFindFunction drop ] keep *void* ; \ No newline at end of file From d4c03d84598ff2ca252b7bb25fea11bace7cb54c Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 30 Jun 2009 11:58:09 +0900 Subject: [PATCH 16/49] add invoker test that tests the entire llvm binding so far --- extra/llvm/invoker/invoker-tests.factor | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 extra/llvm/invoker/invoker-tests.factor diff --git a/extra/llvm/invoker/invoker-tests.factor b/extra/llvm/invoker/invoker-tests.factor new file mode 100644 index 0000000000..7ed723ef66 --- /dev/null +++ b/extra/llvm/invoker/invoker-tests.factor @@ -0,0 +1,8 @@ +USING: alien.llvm io.pathnames llvm.invoker llvm.reader tools.test ; + +[ 3 ] [ + << + "extra/llvm/reader/add.bc" resource-path "add" load-into-jit + "add" install-module + >> 1 2 add +] unit-test \ No newline at end of file From b46999584b3ee645af124e2c91eb7762e781c7c6 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 30 Jun 2009 22:55:20 +0900 Subject: [PATCH 17/49] invoker infers function param c-types more generally --- extra/llvm/invoker/invoker.factor | 6 +++--- extra/llvm/types/types.factor | 14 ++++++++++++++ 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/extra/llvm/invoker/invoker.factor b/extra/llvm/invoker/invoker.factor index 55ebe6db84..2f679ea885 100644 --- a/extra/llvm/invoker/invoker.factor +++ b/extra/llvm/invoker/invoker.factor @@ -30,15 +30,15 @@ TUPLE: function name alien return params ; LLVMGetFirstFunction [ (functions) ] { } make [ ] map ; : function-effect ( function -- effect ) - [ params>> [ first ] map ] [ void? 0 1 ? ] bi ; + [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi ; : install-function ( function -- ) dup name>> "alien.llvm" create-vocab drop "alien.llvm" create swap [ dup name>> function-pointer , - dup return>> drop "int" , - dup params>> [ drop "int" ] map , + dup return>> c-type , + dup params>> [ second c-type ] map , "cdecl" , \ alien-indirect , ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ; diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor index 1d528fb699..6313037e6f 100644 --- a/extra/llvm/types/types.factor +++ b/extra/llvm/types/types.factor @@ -18,20 +18,32 @@ IN: llvm.types ! GENERIC: (>tref) ( type -- LLVMTypeRef ) GENERIC: ((tref>)) ( LLVMTypeRef type -- type ) +GENERIC: c-type ( type -- str ) ! default implementation for simple types M: object ((tref>)) nip ; +: unsupported-type ( -- ) + "cannot generate c-type: unsupported llvm type" throw ; +M: object c-type unsupported-type ; TUPLE: integer size ; C: integer M: integer (>tref) size>> LLVMIntType ; M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ; +M: integer c-type size>> { + { 64 [ "longlong" ] } + { 32 [ "int" ] } + { 16 [ "short" ] } + { 8 [ "char" ] } + [ unsupported-type ] +} case ; SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ; M: float (>tref) drop LLVMFloatType ; M: double (>tref) drop LLVMDoubleType ; +M: double c-type drop "double" ; M: x86_fp80 (>tref) drop LLVMX86FP80Type ; M: fp128 (>tref) drop LLVMFP128Type ; M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ; @@ -41,6 +53,7 @@ SINGLETONS: opaque label void metadata ; M: opaque (>tref) drop LLVMOpaqueType ; M: label (>tref) drop LLVMLabelType ; M: void (>tref) drop LLVMVoidType ; +M: void c-type drop "void" ; M: metadata (>tref) drop "metadata types unsupported by llvm c bindings" throw ; @@ -85,6 +98,7 @@ TUPLE: pointer < enclosing type ; M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ; M: pointer clean* type>> clean ; M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ; +M: pointer c-type type>> 8 = "char*" "void*" ? ; TUPLE: vector < enclosing size type ; : ( s t -- o ) From c1d08d213fdbaeb74a5631faa899cc12fd21687a Mon Sep 17 00:00:00 2001 From: Phil Dawes Date: Tue, 30 Jun 2009 16:26:51 +0100 Subject: [PATCH 18/49] Added thead, tfoot to html --- extra/html/elements/elements.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 85df4f7b27..119662348f 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -98,7 +98,7 @@ SYMBOL: html [ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" "ol" "li" "form" "a" "p" "html" "head" "body" "title" - "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" + "b" "i" "ul" "table" "thead" "tfoot" "tbody" "tr" "td" "th" "pre" "textarea" "script" "div" "span" "select" "option" "style" "input" "strong" ] [ define-closed-html-word ] each From 778707e8fa208eb7aacd1b95f2df557e7590fd3b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Wed, 1 Jul 2009 11:08:57 +0900 Subject: [PATCH 19/49] add license and copywrite to extra/llvm vocabs --- extra/llvm/core/core.factor | 2 ++ extra/llvm/engine/engine.factor | 2 ++ extra/llvm/invoker/invoker-tests.factor | 2 ++ extra/llvm/invoker/invoker.factor | 2 ++ extra/llvm/jit/jit-tests.factor | 2 ++ extra/llvm/jit/jit.factor | 2 ++ extra/llvm/reader/reader.factor | 2 ++ extra/llvm/types/types-tests.factor | 2 ++ extra/llvm/types/types.factor | 2 ++ extra/llvm/wrappers/wrappers-tests.factor | 2 ++ extra/llvm/wrappers/wrappers.factor | 2 ++ 11 files changed, 22 insertions(+) diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor index f63927455a..00a395d3b2 100644 --- a/extra/llvm/core/core.factor +++ b/extra/llvm/core/core.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: alien.libraries alien.syntax ; IN: llvm.core diff --git a/extra/llvm/engine/engine.factor b/extra/llvm/engine/engine.factor index ad51d02785..1fa7ef01d6 100644 --- a/extra/llvm/engine/engine.factor +++ b/extra/llvm/engine/engine.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: alien.libraries alien.syntax llvm.core ; IN: llvm.engine diff --git a/extra/llvm/invoker/invoker-tests.factor b/extra/llvm/invoker/invoker-tests.factor index 7ed723ef66..4e423fa288 100644 --- a/extra/llvm/invoker/invoker-tests.factor +++ b/extra/llvm/invoker/invoker-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: alien.llvm io.pathnames llvm.invoker llvm.reader tools.test ; [ 3 ] [ diff --git a/extra/llvm/invoker/invoker.factor b/extra/llvm/invoker/invoker.factor index 2f679ea885..bb1b06bcf3 100644 --- a/extra/llvm/invoker/invoker.factor +++ b/extra/llvm/invoker/invoker.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays assocs compiler.units effects io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader llvm.types make namespaces sequences specialized-arrays.alien diff --git a/extra/llvm/jit/jit-tests.factor b/extra/llvm/jit/jit-tests.factor index 9808ecb953..5dc2b2c96f 100644 --- a/extra/llvm/jit/jit-tests.factor +++ b/extra/llvm/jit/jit-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: destructors llvm.jit llvm.wrappers tools.test ; [ ] [ "test" "test" add-module "test" remove-module ] unit-test \ No newline at end of file diff --git a/extra/llvm/jit/jit.factor b/extra/llvm/jit/jit.factor index 9281b609e3..f58851fe6f 100644 --- a/extra/llvm/jit/jit.factor +++ b/extra/llvm/jit/jit.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax assocs destructors kernel llvm.core llvm.engine llvm.wrappers namespaces ; diff --git a/extra/llvm/reader/reader.factor b/extra/llvm/reader/reader.factor index 8ff6d50e96..8c324b41e4 100644 --- a/extra/llvm/reader/reader.factor +++ b/extra/llvm/reader/reader.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax destructors kernel llvm.core llvm.engine llvm.jit llvm.wrappers ; diff --git a/extra/llvm/types/types-tests.factor b/extra/llvm/types/types-tests.factor index d38dbf1d5b..d715fe97df 100644 --- a/extra/llvm/types/types-tests.factor +++ b/extra/llvm/types/types-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: kernel llvm.types sequences tools.test ; [ T{ integer f 32 } ] [ " i32 " parse-type ] unit-test diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor index 6313037e6f..a88c45c6cf 100644 --- a/extra/llvm/types/types.factor +++ b/extra/llvm/types/types.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators kernel llvm.core locals math.parser math multiline namespaces parser peg.ebnf sequences diff --git a/extra/llvm/wrappers/wrappers-tests.factor b/extra/llvm/wrappers/wrappers-tests.factor index 321762e2cf..b9f3a7ad32 100644 --- a/extra/llvm/wrappers/wrappers-tests.factor +++ b/extra/llvm/wrappers/wrappers-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: destructors kernel llvm.wrappers sequences tools.test vocabs ; [ ] [ "test" dispose ] unit-test diff --git a/extra/llvm/wrappers/wrappers.factor b/extra/llvm/wrappers/wrappers.factor index 22da1b36f4..a1d757e7e9 100644 --- a/extra/llvm/wrappers/wrappers.factor +++ b/extra/llvm/wrappers/wrappers.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.strings io.encodings.utf8 destructors kernel llvm.core llvm.engine ; From b0ca5ecffa04df22412a3961057be5e7047d493c Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Wed, 1 Jul 2009 14:52:15 +0900 Subject: [PATCH 20/49] updated llvm.invoker test to use install-bc --- extra/llvm/invoker/invoker-tests.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/llvm/invoker/invoker-tests.factor b/extra/llvm/invoker/invoker-tests.factor index 4e423fa288..9041c22f71 100644 --- a/extra/llvm/invoker/invoker-tests.factor +++ b/extra/llvm/invoker/invoker-tests.factor @@ -3,8 +3,5 @@ USING: alien.llvm io.pathnames llvm.invoker llvm.reader tools.test ; [ 3 ] [ - << - "extra/llvm/reader/add.bc" resource-path "add" load-into-jit - "add" install-module - >> 1 2 add + << "resource:extra/llvm/reader/add.bc" install-bc >> 1 2 add ] unit-test \ No newline at end of file From c20e6c290f94d80cf853c093c8b54991f8a05f7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Jul 2009 23:07:06 -0500 Subject: [PATCH 21/49] compiler.cfg.linear-scan: split off parallel mapping code from resolve pass, use it in assignment pass to resolve parallel copies --- .../allocation/spilling/spilling.factor | 2 +- .../linear-scan/assignment/assignment.factor | 37 ++--- .../cfg/linear-scan/linear-scan.factor | 4 +- .../cfg/linear-scan/mapping/mapping.factor | 148 +++++++++++++++++ .../cfg/linear-scan/resolve/resolve.factor | 150 +----------------- core/hashtables/hashtables-tests.factor | 3 + 6 files changed, 177 insertions(+), 167 deletions(-) create mode 100644 basis/compiler/cfg/linear-scan/mapping/mapping.factor diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 9949832294..c747d2b404 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ; } 2cleave ; : assign-spill ( live-interval -- ) - dup vreg>> assign-spill-slot >>spill-to drop ; + dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ; : assign-reload ( live-interval -- ) dup vreg>> assign-spill-slot >>reload-from drop ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index c995569c2e..143e84aaf4 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -8,6 +8,7 @@ compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -42,16 +43,11 @@ SYMBOL: register-live-outs H{ } clone register-live-outs set init-unhandled ; -: insert-spill ( live-interval -- ) - { - [ reg>> ] - [ vreg>> reg-class>> ] - [ spill-to>> ] - [ end>> ] - } cleave f swap \ _spill boa , ; - : handle-spill ( live-interval -- ) - dup spill-to>> [ insert-spill ] [ drop ] if ; + dup spill-to>> [ + [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri + register->memory + ] [ drop ] if ; : first-split ( live-interval -- live-interval' ) dup split-before>> [ first-split ] [ ] ?if ; @@ -59,22 +55,19 @@ SYMBOL: register-live-outs : next-interval ( live-interval -- live-interval' ) split-next>> first-split ; -: insert-copy ( live-interval -- ) - { - [ next-interval reg>> ] - [ reg>> ] - [ vreg>> reg-class>> ] - [ end>> ] - } cleave f swap \ _copy boa , ; - : handle-copy ( live-interval -- ) - dup split-next>> [ insert-copy ] [ drop ] if ; + dup split-next>> [ + [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri + register->register + ] [ drop ] if ; : expire-old-intervals ( n -- ) - [ pending-intervals get ] dip '[ - dup end>> _ < - [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if - ] filter-here ; + [ + [ pending-intervals get ] dip '[ + dup end>> _ < + [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if + ] filter-here + ] { } make mapping-instructions % ; : insert-reload ( live-interval -- ) { diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 9013389cc9..77d66c274d 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.resolve ; +compiler.cfg.linear-scan.resolve +compiler.cfg.linear-scan.mapping ; IN: compiler.cfg.linear-scan ! References: @@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan : linear-scan ( cfg -- cfg' ) [ + init-mapping dup reverse-post-order machine-registers (linear-scan) spill-counts get >>spill-counts ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor new file mode 100644 index 0000000000..5b47f33c64 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor @@ -0,0 +1,148 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.parser classes.tuple +combinators compiler.cfg.instructions +compiler.cfg.linear-scan.allocation.state fry hashtables kernel +locals make namespaces parser sequences sets words ; +IN: compiler.cfg.linear-scan.mapping + +SYMBOL: spill-temps + +: spill-temp ( reg-class -- n ) + spill-temps get [ next-spill-slot ] cache ; + +<< + +TUPLE: operation from to reg-class ; + +SYNTAX: OPERATION: + CREATE-CLASS dup save-location + [ operation { } define-tuple-class ] + [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; + +>> + +OPERATION: register->memory +OPERATION: memory->register +OPERATION: register->register + +! This should never come up because of how spill slots are assigned, +! so make it an error. +: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; + +GENERIC: >insn ( operation -- ) + +M: register->memory >insn + [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; + +M: memory->register >insn + [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; + +M: register->register >insn + [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; + +SYMBOL: froms +SYMBOL: tos + +SINGLETONS: memory register ; + +: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; + +: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; + +: from-reg ( operation -- seq ) + [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; + +: to-reg ( operation -- seq ) + [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; + +: start? ( operations -- pair ) + from-reg tos get key? not ; + +: independent-assignment? ( operations -- pair ) + to-reg froms get key? not ; + +: set-tos/froms ( operations -- ) + [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] + [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] + bi ; + +:: (trace-chain) ( obj hashtable -- ) + obj to-reg froms get at* [ + dup , + obj over hashtable clone [ maybe-set-at ] keep swap + [ (trace-chain) ] [ 2drop ] if + ] [ + drop + ] if ; + +: trace-chain ( obj -- seq ) + [ + dup , + dup dup associate (trace-chain) + ] { } make prune reverse ; + +: trace-chains ( seq -- seq' ) + [ trace-chain ] map concat ; + +ERROR: resolve-error ; + +: split-cycle ( operations -- chain spilled-operation ) + unclip [ + [ set-tos/froms ] + [ + [ start? ] find nip + [ resolve-error ] unless* trace-chain + ] bi + ] dip ; + +: break-cycle-n ( operations -- operations' ) + split-cycle [ + [ from>> ] + [ reg-class>> spill-temp ] + [ reg-class>> ] + tri \ register->memory boa + ] [ + [ reg-class>> spill-temp ] + [ to>> ] + [ reg-class>> ] + tri \ memory->register boa + ] bi [ 1array ] bi@ surround ; + +: break-cycle ( operations -- operations' ) + dup length { + { 1 [ ] } + [ drop break-cycle-n ] + } case ; + +: (group-cycles) ( seq -- ) + [ + dup set-tos/froms + unclip trace-chain + [ diff ] keep , (group-cycles) + ] unless-empty ; + +: group-cycles ( seq -- seqs ) + [ (group-cycles) ] { } make ; + +: remove-dead-mappings ( seq -- seq' ) + prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; + +: parallel-mappings ( operations -- seq ) + [ + [ independent-assignment? not ] partition % + [ start? not ] partition + [ trace-chain ] map concat dup % + diff group-cycles [ break-cycle ] map concat % + ] { } make remove-dead-mappings ; + +: mapping-instructions ( mappings -- insns ) + [ { } ] [ + [ + [ set-tos/froms ] [ parallel-mappings ] bi + [ [ >insn ] each ] { } make + ] with-scope + ] if-empty ; + +: init-mapping ( -- ) + H{ } clone spill-temps set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 196d8e439f..7b7f242e4e 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,36 +1,13 @@ -! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.parser classes.tuple -combinators combinators.short-circuit fry hashtables kernel locals -make math math.order namespaces sequences sets words parser -compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.assignment compiler.cfg.liveness ; +USING: accessors arrays assocs combinators +combinators.short-circuit fry kernel locals +make math sequences +compiler.cfg.instructions +compiler.cfg.linear-scan.assignment +compiler.cfg.linear-scan.mapping compiler.cfg.liveness ; IN: compiler.cfg.linear-scan.resolve -SYMBOL: spill-temps - -: spill-temp ( reg-class -- n ) - spill-temps get [ next-spill-slot ] cache ; - -<< - -TUPLE: operation from to reg-class ; - -SYNTAX: OPERATION: - CREATE-CLASS dup save-location - [ operation { } define-tuple-class ] - [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; - ->> - -OPERATION: register->memory -OPERATION: memory->register -OPERATION: register->register - -! This should never come up because of how spill slots are assigned, -! so make it an error. -: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; - : add-mapping ( from to reg-class -- ) over spill-slot? [ pick spill-slot? @@ -53,118 +30,6 @@ OPERATION: register->register [ resolve-value-data-flow ] with with each ] { } make ; -GENERIC: >insn ( operation -- ) - -M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; - -M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; - -M: register->register >insn - [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; - -SYMBOL: froms -SYMBOL: tos - -SINGLETONS: memory register ; - -: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; - -: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; - -: from-reg ( operation -- seq ) - [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; - -: to-reg ( operation -- seq ) - [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; - -: start? ( operations -- pair ) - from-reg tos get key? not ; - -: independent-assignment? ( operations -- pair ) - to-reg froms get key? not ; - -: set-tos/froms ( operations -- ) - [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] - [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] - bi ; - -:: (trace-chain) ( obj hashtable -- ) - obj to-reg froms get at* [ - dup , - obj over hashtable clone [ maybe-set-at ] keep swap - [ (trace-chain) ] [ 2drop ] if - ] [ - drop - ] if ; - -: trace-chain ( obj -- seq ) - [ - dup , - dup dup associate (trace-chain) - ] { } make prune reverse ; - -: trace-chains ( seq -- seq' ) - [ trace-chain ] map concat ; - -ERROR: resolve-error ; - -: split-cycle ( operations -- chain spilled-operation ) - unclip [ - [ set-tos/froms ] - [ - [ start? ] find nip - [ resolve-error ] unless* trace-chain - ] bi - ] dip ; - -: break-cycle-n ( operations -- operations' ) - split-cycle [ - [ from>> ] - [ reg-class>> spill-temp ] - [ reg-class>> ] - tri \ register->memory boa - ] [ - [ reg-class>> spill-temp ] - [ to>> ] - [ reg-class>> ] - tri \ memory->register boa - ] bi [ 1array ] bi@ surround ; - -: break-cycle ( operations -- operations' ) - dup length { - { 1 [ ] } - [ drop break-cycle-n ] - } case ; - -: (group-cycles) ( seq -- ) - [ - dup set-tos/froms - unclip trace-chain - [ diff ] keep , (group-cycles) - ] unless-empty ; - -: group-cycles ( seq -- seqs ) - [ (group-cycles) ] { } make ; - -: remove-dead-mappings ( seq -- seq' ) - prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; - -: parallel-mappings ( operations -- seq ) - [ - [ independent-assignment? not ] partition % - [ start? not ] partition - [ trace-chain ] map concat dup % - diff group-cycles [ break-cycle ] map concat % - ] { } make remove-dead-mappings ; - -: mapping-instructions ( mappings -- insns ) - [ - [ set-tos/froms ] [ parallel-mappings ] bi - [ [ >insn ] each ] { } make - ] with-scope ; - : fork? ( from to -- ? ) { [ drop successors>> length 1 >= ] @@ -206,5 +71,4 @@ ERROR: resolve-error ; dup successors>> [ resolve-edge-data-flow ] with each ; : resolve-data-flow ( rpo -- ) - H{ } clone spill-temps set [ resolve-block-data-flow ] each ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 0e6deb7746..004b543c7f 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -176,3 +176,6 @@ H{ } "x" set [ 1 ] [ "h" get assoc-size ] unit-test [ 1 ] [ 2 "h" get at ] unit-test + +! Random test case +[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test \ No newline at end of file From 4507bdcbc077498959b12e5463038d8e774159c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Jul 2009 23:28:28 -0500 Subject: [PATCH 22/49] compiler.cfg.linear-scan: code cleanups --- .../linear-scan/allocation/allocation.factor | 2 +- .../allocation/spilling/spilling.factor | 68 +++++++++++-------- .../allocation/splitting/splitting.factor | 2 +- .../cfg/linear-scan/linear-scan-tests.factor | 6 +- 4 files changed, 45 insertions(+), 33 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 7dd3977605..42b38e6260 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -29,7 +29,7 @@ IN: compiler.cfg.linear-scan.allocation second 0 = ; inline : register-partially-available ( new result -- ) - [ second split-before-use ] keep + [ second split-to-fit ] keep '[ _ register-available ] [ add-unhandled ] bi* ; : assign-register ( new -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index c747d2b404..b4240ea813 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -80,10 +80,10 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; -: split-intersecting? ( live-interval new reg -- ? ) - { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; - -: split-live-out ( live-interval -- ) +: spill-live-out ( live-interval -- ) + ! The interval has no more usages after the spill location. This + ! means it is the first child of an interval that was split. We + ! spill the value and let the resolve pass insert a reload later. { [ trim-before-ranges ] [ compute-start/end ] @@ -91,7 +91,11 @@ ERROR: bad-live-ranges interval ; [ add-handled ] } cleave ; -: split-live-in ( live-interval -- ) +: spill-live-in ( live-interval -- ) + ! The interval does not have any usages before the spill location. + ! This means it is the second child of an interval that was + ! split. We reload the value and let the resolve pass insert a + ! split later. { [ trim-after-ranges ] [ compute-start/end ] @@ -99,40 +103,48 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; -: (split-intersecting) ( live-interval new -- ) +: (spill-intersecting) ( live-interval new -- ) start>> { - { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] } - { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] } + { [ 2dup [ uses>> last ] dip < ] [ drop spill-live-out ] } + { [ 2dup [ uses>> first ] dip > ] [ drop spill-live-in ] } [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] } cond ; -: (split-intersecting-active) ( active new -- ) - [ drop delete-active ] - [ (split-intersecting) ] 2bi ; +:: spill-intersecting-active ( new reg -- ) + ! If there is an active interval using 'reg' (there should be at + ! most one) are split and spilled and removed from the inactive + ! set. + new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep + '[ _ delete-nth new (spill-intersecting) ] [ 2drop ] if ; -: split-intersecting-active ( new reg -- ) - [ [ vreg>> active-intervals-for ] keep ] dip - [ '[ _ _ split-intersecting? ] filter ] 2keep drop - '[ _ (split-intersecting-active) ] each ; +:: spill-intersecting-inactive ( new reg -- ) + ! Any inactive intervals using 'reg' are split and spilled + ! and removed from the inactive set. + new vreg>> inactive-intervals-for [ + dup reg>> reg = [ + dup new intervals-intersect? [ + new (spill-intersecting) f + ] [ drop t ] if + ] [ drop t ] if + ] filter-here ; -: (split-intersecting-inactive) ( inactive new -- ) - [ drop delete-inactive ] - [ (split-intersecting) ] 2bi ; - -: split-intersecting-inactive ( new reg -- ) - [ [ vreg>> inactive-intervals-for ] keep ] dip - [ '[ _ _ split-intersecting? ] filter ] 2keep drop - '[ _ (split-intersecting-inactive) ] each ; - -: split-intersecting ( new reg -- ) - [ split-intersecting-active ] - [ split-intersecting-inactive ] +: spill-intersecting ( new reg -- ) + ! Split and spill all active and inactive intervals + ! which intersect 'new' and use 'reg'. + [ spill-intersecting-active ] + [ spill-intersecting-inactive ] 2bi ; : spill-available ( new pair -- ) - [ first split-intersecting ] [ register-available ] 2bi ; + ! A register would become fully available if all + ! active and inactive intervals using it were split + ! and spilled. + [ first spill-intersecting ] [ register-available ] 2bi ; : spill-partially-available ( new pair -- ) + ! A register would be available for part of the new + ! interval's lifetime if all active and inactive intervals + ! using that register were split and spilled. [ second 1 - split-and-spill add-unhandled ] keep spill-available ; diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 71d3d56285..4e33334730 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -72,7 +72,7 @@ HINTS: split-interval live-interval object ; [ 1 + '[ _ > ] filter ] 2tri 3append ; -: split-before-use ( new n -- before after ) +: split-to-fit ( new n -- before after ) 1 - 2dup swap covers? [ [ '[ _ insert-use-for-copy ] change-uses ] keep diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index b5999838ca..7d2d367af8 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -175,7 +175,7 @@ check-numbering? on { end 5 } { uses V{ 0 1 5 } } { ranges V{ T{ live-range f 0 5 } } } - } 5 split-before-use [ f >>split-next ] bi@ + } 5 split-to-fit [ f >>split-next ] bi@ ] unit-test [ @@ -200,7 +200,7 @@ check-numbering? on { end 10 } { uses V{ 0 1 10 } } { ranges V{ T{ live-range f 0 10 } } } - } 5 split-before-use [ f >>split-next ] bi@ + } 5 split-to-fit [ f >>split-next ] bi@ ] unit-test [ @@ -225,7 +225,7 @@ check-numbering? on { end 10 } { uses V{ 0 1 4 5 10 } } { ranges V{ T{ live-range f 0 10 } } } - } 5 split-before-use [ f >>split-next ] bi@ + } 5 split-to-fit [ f >>split-next ] bi@ ] unit-test [ From 5a6429038634ed47d2c272ed975af00edb336420 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 00:20:03 -0500 Subject: [PATCH 23/49] compiler.cfg.linear-scan: more code cleanups, and working on split-to-fit algorithm --- .../linear-scan/allocation/allocation.factor | 20 ++++++- .../allocation/spilling/spilling.factor | 16 ++++-- .../allocation/splitting/splitting.factor | 20 ------- .../cfg/linear-scan/linear-scan-tests.factor | 56 +------------------ 4 files changed, 29 insertions(+), 83 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 42b38e6260..c197da9814 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -28,16 +28,30 @@ IN: compiler.cfg.linear-scan.allocation : no-free-registers? ( result -- ? ) second 0 = ; inline +: split-to-fit ( new n -- before after ) + split-interval + [ [ compute-start/end ] bi@ ] + [ >>split-next drop ] + [ ] + 2tri ; + : register-partially-available ( new result -- ) - [ second split-to-fit ] keep - '[ _ register-available ] [ add-unhandled ] bi* ; + { + { [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] } + { [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] } + [ + [ second 1 - split-to-fit ] keep + '[ _ register-available ] [ add-unhandled ] bi* + ] + } cond ; : assign-register ( new -- ) dup coalesce? [ coalesce ] [ dup register-status { { [ dup no-free-registers? ] [ drop assign-blocked-register ] } { [ 2dup register-available? ] [ register-available ] } - [ register-partially-available ] + ! [ register-partially-available ] + [ drop assign-blocked-register ] } cond ] if ; diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index b4240ea813..b89c1f4de2 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -80,6 +80,8 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; +: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ; + : spill-live-out ( live-interval -- ) ! The interval has no more usages after the spill location. This ! means it is the first child of an interval that was split. We @@ -91,6 +93,8 @@ ERROR: bad-live-ranges interval ; [ add-handled ] } cleave ; +: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ; + : spill-live-in ( live-interval -- ) ! The interval does not have any usages before the spill location. ! This means it is the second child of an interval that was @@ -103,10 +107,10 @@ ERROR: bad-live-ranges interval ; [ add-unhandled ] } cleave ; -: (spill-intersecting) ( live-interval new -- ) - start>> { - { [ 2dup [ uses>> last ] dip < ] [ drop spill-live-out ] } - { [ 2dup [ uses>> first ] dip > ] [ drop spill-live-in ] } +: spill ( live-interval n -- ) + { + { [ 2dup spill-live-out? ] [ drop spill-live-out ] } + { [ 2dup spill-live-in? ] [ drop spill-live-in ] } [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] } cond ; @@ -115,7 +119,7 @@ ERROR: bad-live-ranges interval ; ! most one) are split and spilled and removed from the inactive ! set. new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep - '[ _ delete-nth new (spill-intersecting) ] [ 2drop ] if ; + '[ _ delete-nth new start>> spill ] [ 2drop ] if ; :: spill-intersecting-inactive ( new reg -- ) ! Any inactive intervals using 'reg' are split and spilled @@ -123,7 +127,7 @@ ERROR: bad-live-ranges interval ; new vreg>> inactive-intervals-for [ dup reg>> reg = [ dup new intervals-intersect? [ - new (spill-intersecting) f + new start>> spill f ] [ drop t ] if ] [ drop t ] if ] filter-here ; diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 4e33334730..0a67710bc8 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -61,23 +61,3 @@ ERROR: splitting-atomic-interval ; after split-after ; HINTS: split-interval live-interval object ; - -: split-between-blocks ( new n -- before after ) - split-interval - 2dup [ compute-start/end ] bi@ ; - -: insert-use-for-copy ( seq n -- seq' ) - [ '[ _ < ] filter ] - [ nip dup 1 + 2array ] - [ 1 + '[ _ > ] filter ] - 2tri 3append ; - -: split-to-fit ( new n -- before after ) - 1 - - 2dup swap covers? [ - [ '[ _ insert-use-for-copy ] change-uses ] keep - split-between-blocks - 2dup >>split-next drop - ] [ - split-between-blocks - ] if ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 7d2d367af8..06817071d4 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1,7 +1,7 @@ IN: compiler.cfg.linear-scan.tests USING: tools.test random sorting sequences sets hashtables assocs kernel fry arrays splitting namespaces math accessors vectors locals -math.order grouping strings strings.private +math.order grouping strings strings.private classes cpu.architecture compiler.cfg compiler.cfg.optimizer @@ -153,56 +153,6 @@ check-numbering? on } 10 split-for-spill [ f >>split-next ] bi@ ] unit-test -[ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 4 } - { uses V{ 0 1 4 } } - { ranges V{ T{ live-range f 0 4 } } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 5 } - { uses V{ 5 } } - { ranges V{ T{ live-range f 5 5 } } } - } -] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 5 } - { uses V{ 0 1 5 } } - { ranges V{ T{ live-range f 0 5 } } } - } 5 split-to-fit [ f >>split-next ] bi@ -] unit-test - -[ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 4 } - { uses V{ 0 1 4 } } - { ranges V{ T{ live-range f 0 4 } } } - } - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 5 } - { end 10 } - { uses V{ 5 10 } } - { ranges V{ T{ live-range f 5 10 } } } - } -] [ - T{ live-interval - { vreg T{ vreg { reg-class int-regs } { n 1 } } } - { start 0 } - { end 10 } - { uses V{ 0 1 10 } } - { ranges V{ T{ live-range f 0 10 } } } - } 5 split-to-fit [ f >>split-next ] bi@ -] unit-test - [ T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -225,7 +175,7 @@ check-numbering? on { end 10 } { uses V{ 0 1 4 5 10 } } { ranges V{ T{ live-range f 0 10 } } } - } 5 split-to-fit [ f >>split-next ] bi@ + } 4 split-to-fit [ f >>split-next ] bi@ ] unit-test [ @@ -1847,8 +1797,6 @@ test-diamond [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test -USING: classes ; - [ ] [ 1 get instructions>> first regs>> V int-regs 0 swap at 2 get instructions>> first regs>> V int-regs 1 swap at assert= From d0980edafe3de44359dba17df5ccfdf6fa113550 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 00:48:00 -0500 Subject: [PATCH 24/49] compiler.cfg.linear-scan: fixing unit tests --- .../linear-scan/mapping/mapping-tests.factor | 145 +++++++++++++++++ .../linear-scan/resolve/resolve-tests.factor | 151 +----------------- 2 files changed, 147 insertions(+), 149 deletions(-) create mode 100644 basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor new file mode 100644 index 0000000000..d12167574a --- /dev/null +++ b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor @@ -0,0 +1,145 @@ +USING: compiler.cfg.instructions +compiler.cfg.linear-scan.allocation.state +compiler.cfg.linear-scan.mapping cpu.architecture kernel +namespaces tools.test ; +IN: compiler.cfg.linear-scan.mapping.tests + +H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +init-mapping + +[ + { + T{ _copy { dst 5 } { src 4 } { class int-regs } } + T{ _spill { src 1 } { class int-regs } { n 10 } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { class int-regs } { n 10 } } + T{ _spill { src 1 } { class float-regs } { n 20 } } + T{ _copy { dst 1 } { src 0 } { class float-regs } } + T{ _reload { dst 0 } { class float-regs } { n 20 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 1 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 1 } { reg-class float-regs } } + T{ register->register { from 1 } { to 0 } { reg-class float-regs } } + T{ register->register { from 4 } { to 5 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _spill { src 2 } { class int-regs } { n 10 } } + T{ _copy { dst 2 } { src 1 } { class int-regs } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { class int-regs } { n 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 1 } { to 2 } { reg-class int-regs } } + T{ register->register { from 2 } { to 0 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _spill { src 0 } { class int-regs } { n 10 } } + T{ _copy { dst 0 } { src 2 } { class int-regs } } + T{ _copy { dst 2 } { src 1 } { class int-regs } } + T{ _reload { dst 1 } { class int-regs } { n 10 } } + } +] [ + { + T{ register->register { from 1 } { to 2 } { reg-class int-regs } } + T{ register->register { from 2 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _copy { dst 2 } { src 0 } { class int-regs } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { } +] [ + { + T{ register->register { from 4 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _spill { src 3 } { class int-regs } { n 4 } } + T{ _reload { dst 2 } { class int-regs } { n 1 } } + } +] [ + { + T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } + T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + + +[ + { + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _copy { dst 2 } { src 0 } { class int-regs } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _copy { dst 2 } { src 0 } { class int-regs } } + T{ _spill { src 4 } { class int-regs } { n 10 } } + T{ _copy { dst 4 } { src 0 } { class int-regs } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + T{ _reload { dst 3 } { class int-regs } { n 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 4 } { to 3 } { reg-class int-regs } } + T{ register->register { from 0 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test + +[ + { + T{ _copy { dst 2 } { src 0 } { class int-regs } } + T{ _copy { dst 9 } { src 1 } { class int-regs } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _spill { src 4 } { class int-regs } { n 10 } } + T{ _copy { dst 4 } { src 0 } { class int-regs } } + T{ _copy { dst 0 } { src 3 } { class int-regs } } + T{ _reload { dst 3 } { class int-regs } { n 10 } } + } +] [ + { + T{ register->register { from 0 } { to 1 } { reg-class int-regs } } + T{ register->register { from 0 } { to 2 } { reg-class int-regs } } + T{ register->register { from 1 } { to 9 } { reg-class int-regs } } + T{ register->register { from 3 } { to 0 } { reg-class int-regs } } + T{ register->register { from 4 } { to 3 } { reg-class int-regs } } + T{ register->register { from 0 } { to 4 } { reg-class int-regs } } + } mapping-instructions +] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 7e308cf231..b5e95258bf 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -1,154 +1,7 @@ -USING: accessors arrays classes compiler.cfg -compiler.cfg.debugger compiler.cfg.instructions -compiler.cfg.linear-scan.debugger -compiler.cfg.linear-scan.live-intervals -compiler.cfg.linear-scan.numbering -compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.resolve compiler.cfg.predecessors -compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel -namespaces tools.test vectors ; +USING: arrays compiler.cfg.linear-scan.resolve kernel +tools.test ; IN: compiler.cfg.linear-scan.resolve.tests [ { 1 2 3 4 5 6 } ] [ { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array ] unit-test - -H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set -H{ } clone spill-temps set - -[ - { - T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 1 } { class int-regs } { n 10 } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - T{ _spill { src 1 } { class float-regs } { n 20 } } - T{ _copy { dst 1 } { src 0 } { class float-regs } } - T{ _reload { dst 0 } { class float-regs } { n 20 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class float-regs } } - T{ register->register { from 1 } { to 0 } { reg-class float-regs } } - T{ register->register { from 4 } { to 5 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 2 } { class int-regs } { n 10 } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 0 } { class int-regs } { n 10 } } - T{ _copy { dst 0 } { src 2 } { class int-regs } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { } -] [ - { - T{ register->register { from 4 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 3 } { class int-regs } { n 4 } } - T{ _reload { dst 2 } { class int-regs } { n 1 } } - } -] [ - { - T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } - T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 9 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 1 } { to 9 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test From e0d84eb3a21906c388d2b238fdc03332ba7820b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 02:28:30 -0500 Subject: [PATCH 25/49] compiler.tree.propagation: better length propagation --- .../compiler/tree/propagation/info/info.factor | 17 +++++++++++------ .../tree/propagation/propagation-tests.factor | 10 ++++++++++ 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 50762c2b66..816368466f 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals -namespaces sequences words combinators +namespaces sequences words combinators byte-arrays strings arrays compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info @@ -66,12 +66,17 @@ DEFER: [ read-only>> [ ] [ drop f ] if ] 2map f prefix ; +UNION: fixed-length array byte-array string ; + : init-literal-info ( info -- info ) + [-inf,inf] >>interval dup literal>> class >>class - dup literal>> dup real? [ [a,a] >>interval ] [ - [ [-inf,inf] >>interval ] dip - dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if - ] if ; inline + dup literal>> { + { [ dup real? ] [ [a,a] >>interval ] } + { [ dup tuple? ] [ tuple-slot-infos >>slots ] } + { [ dup fixed-length? ] [ length >>length ] } + [ drop ] + } cond ; inline : init-value-info ( info -- info ) dup literal?>> [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 9cb0e41291..32c9f4ed0b 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -331,6 +331,16 @@ cell-bits 32 = [ [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals ] unit-test +[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 length ] final-literals ] unit-test + +[ V{ 3 } ] [ [ 3 f length ] final-literals ] unit-test + ! Slot propagation TUPLE: prop-test-tuple { x integer } ; From 508b7272b5e95a04473bc816d72e142753697077 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 9 Jul 2009 06:17:10 -0500 Subject: [PATCH 26/49] compiler.cfg.optimizer: fix irrelevant test --- .../compiler/cfg/optimizer/optimizer-tests.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) mode change 100644 => 100755 basis/compiler/cfg/optimizer/optimizer-tests.factor diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor old mode 100644 new mode 100755 index 97ebc7cc3e..93adc4c0f9 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.instructions fry kernel kernel.private math math.private sbufs sequences sequences.private sets -slots.private strings tools.test vectors ; +slots.private strings tools.test vectors layouts ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -35,10 +35,11 @@ IN: compiler.cfg.optimizer.tests [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each -[ t ] -[ +cell 8 = [ + [ t ] [ - HEX: 7fff fixnum-bitand 13 fixnum-shift-fast - 112 23 fixnum-shift-fast fixnum+fast - ] test-mr first instructions>> [ ##add? ] any? -] unit-test + [ + 1 50 fixnum-shift-fast fixnum+fast + ] test-mr first instructions>> [ ##add? ] any? + ] unit-test +] when From d0f2b1c606d3203344c18285353dc2a99c79207b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 06:31:38 -0500 Subject: [PATCH 27/49] io.launcher: unnecessary word --- basis/io/launcher/launcher.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index f4978672d9..34325780c0 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -280,5 +280,3 @@ M: output-process-error error. { [ os winnt? ] [ "io.launcher.windows.nt" require ] } [ ] } cond - -: run-desc ( desc -- result ) ascii f swap stream-read-until drop ; From 097487a9f3cee148a31a2a233ec112c2a0882c1d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 3 Jul 2009 08:18:49 +0200 Subject: [PATCH 28/49] added >upper to push-utf8 to conform with RFC 3986 section 2.1. recommendation --- basis/urls/encoding/encoding.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index a5f5d62bfc..8e11dec431 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -37,7 +37,7 @@ IN: urls.encoding : push-utf8 ( ch -- ) 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ; + [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ; PRIVATE> From ce9406ea869016ba54df3a886525a2991b15e783 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 6 Jul 2009 09:05:20 +0200 Subject: [PATCH 29/49] fixed signed number decoding problem --- extra/bson/reader/reader.factor | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 7e218fa79c..e6ae0060b6 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -1,6 +1,6 @@ -USING: accessors assocs bson.constants byte-arrays byte-vectors fry io -io.binary io.encodings.string io.encodings.utf8 kernel math namespaces -sequences serialize arrays calendar io.encodings ; +USING: accessors assocs bson.constants calendar fry io io.binary +io.encodings io.encodings.utf8 kernel math math.bitwise namespaces +sequences serialize ; FROM: kernel.private => declare ; FROM: io.encodings.private => (read-until) ; @@ -44,20 +44,17 @@ GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) GENERIC: element-binary-read ( length type -- object ) -: byte-array>number ( seq -- number ) - byte-array>bignum >integer ; inline - : get-state ( -- state ) state get ; inline : read-int32 ( -- int32 ) - 4 read byte-array>number ; inline + 4 read signed-le> ; inline : read-longlong ( -- longlong ) - 8 read byte-array>number ; inline + 8 read signed-le> ; inline : read-double ( -- double ) - 8 read byte-array>number bits>double ; inline + 8 read le> bits>double ; inline : read-byte-raw ( -- byte-raw ) 1 read ; inline From 1aad74c71bccca3d44175ce11ca4c93563c682ef Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 5 Jul 2009 13:28:41 +0200 Subject: [PATCH 30/49] removed usages of sprintf made collection handling more concise --- extra/mongodb/benchmark/benchmark.factor | 2 +- extra/mongodb/connection/connection.factor | 10 +-- extra/mongodb/driver/driver-docs.factor | 2 +- extra/mongodb/driver/driver.factor | 79 +++++++++++-------- .../tuple/collection/collection.factor | 2 +- 5 files changed, 52 insertions(+), 43 deletions(-) diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor index 5204846d03..ad8c501605 100644 --- a/extra/mongodb/benchmark/benchmark.factor +++ b/extra/mongodb/benchmark/benchmark.factor @@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ create-collection ] keep ; : prepare-index ( collection -- ) - "_x_idx" [ "x" asc ] key-spec unique-index ensure-index ; + "_x_idx" [ "x" asc ] key-spec t >>unique? ensure-index ; : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) prepare-collection diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index 7477ee5486..af54f2ebc5 100644 --- a/extra/mongodb/connection/connection.factor +++ b/extra/mongodb/connection/connection.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math math.parser mongodb.msg mongodb.operations namespaces destructors -constructors sequences splitting checksums checksums.md5 formatting +constructors sequences splitting checksums checksums.md5 io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart arrays hashtables sequences.deep vectors locals ; @@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; mdb-connection get instance>> ; inline : index-collection ( -- ns ) - mdb-instance name>> "%s.system.indexes" sprintf ; inline + mdb-instance name>> "system.indexes" 2array "." join ; inline : namespaces-collection ( -- ns ) - mdb-instance name>> "%s.system.namespaces" sprintf ; inline + mdb-instance name>> "system.namespaces" 2array "." join ; inline : cmd-collection ( -- ns ) - mdb-instance name>> "%s.$cmd" sprintf ; inline + mdb-instance name>> "$cmd" 2array "." join ; inline : index-ns ( colname -- index-ns ) - [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline + [ mdb-instance name>> ] dip 2array "." join ; inline : send-message ( message -- ) [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor index 7dbf564df9..e8f726374c 100644 --- a/extra/mongodb/driver/driver-docs.factor +++ b/extra/mongodb/driver/driver-docs.factor @@ -131,7 +131,7 @@ HELP: ensure-index "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec ensure-index ] with-db" "" } { $unchecked-example "USING: mongodb.driver ;" - "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec unique-index ensure-index ] with-db" "" } } ; + "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec t >>unique? ensure-index ] with-db" "" } } ; HELP: explain. { $values diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 967d4f11c5..48f0aef4ff 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -1,8 +1,8 @@ -USING: accessors assocs bson.constants bson.writer combinators combinators.smart -constructors continuations destructors formatting fry io io.pools -io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables -namespaces parser prettyprint sequences sets splitting strings uuid arrays -math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ; +USING: accessors arrays assocs bson.constants combinators +combinators.smart constructors destructors formatting fry hashtables +io io.pools io.sockets kernel linked-assocs math mongodb.connection +mongodb.msg parser prettyprint sequences sets splitting strings +tools.continuations uuid memoize locals ; IN: mongodb.driver @@ -23,9 +23,6 @@ TUPLE: index-spec CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ; -: unique-index ( index-spec -- index-spec ) - t >>unique? ; - M: mdb-pool make-connection mdb>> mdb-open ; @@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result [ make-cursor ] 2tri swap objects>> ; +: make-collection-assoc ( collection assoc -- ) + [ [ name>> "create" ] dip set-at ] + [ [ [ capped>> ] keep ] dip + '[ _ _ + [ [ drop t "capped" ] dip set-at ] + [ [ size>> "size" ] dip set-at ] + [ [ max>> "max" ] dip set-at ] 2tri ] when + ] 2bi ; + PRIVATE> SYNTAX: r/ ( token -- mdbregexp ) @@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp ) H{ } clone [ set-at ] keep [ verify-nodes ] keep ; -GENERIC: create-collection ( name -- ) +GENERIC: create-collection ( name/collection -- ) M: string create-collection create-collection ; M: mdb-collection create-collection - [ cmd-collection ] dip - [ - [ [ name>> "create" ] dip set-at ] - [ [ [ capped>> ] keep ] dip - '[ _ _ - [ [ drop t "capped" ] dip set-at ] - [ [ size>> "size" ] dip set-at ] - [ [ max>> "max" ] dip set-at ] 2tri ] when - ] 2bi - ] keep 1 >>return# send-query-plain drop ; - + [ [ cmd-collection ] dip + [ make-collection-assoc ] keep + 1 >>return# send-query-plain drop ] keep + [ ] [ name>> ] bi mdb-instance collections>> set-at ; + : load-collection-list ( -- collection-list ) namespaces-collection H{ } clone send-query-plain objects>> ; @@ -125,27 +125,36 @@ M: mdb-collection create-collection : ensure-valid-collection-name ( collection -- ) [ ";$." intersect length 0 > ] keep - '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline + '[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline -: (ensure-collection) ( collection -- ) - mdb-instance collections>> dup keys length 0 = - [ load-collection-list - [ [ "options" ] dip key? ] filter - [ [ "name" ] dip at "." split second ] map - over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if - [ dup ] dip key? [ drop ] - [ [ ensure-valid-collection-name ] keep create-collection ] if ; +: build-collection-map ( -- assoc ) + H{ } clone load-collection-list + [ [ "name" ] dip at "." split second ] map + over '[ [ ] [ name>> ] bi _ set-at ] each ; +: ensure-collection-map ( mdb-instance -- assoc ) + dup collections>> dup keys length 0 = + [ drop build-collection-map [ >>collections drop ] keep ] + [ nip ] if ; + +: (ensure-collection) ( collection mdb-instance -- collection ) + ensure-collection-map [ dup ] dip key? + [ ] [ [ ensure-valid-collection-name ] + [ create-collection ] + [ ] tri ] if ; + : reserved-namespace? ( name -- ? ) [ "$cmd" = ] [ "system" head? ] bi or ; : check-collection ( collection -- fq-collection ) - dup mdb-collection? [ name>> ] when - "." split1 over mdb-instance name>> = - [ nip ] [ drop ] if - [ ] [ reserved-namespace? ] bi - [ [ (ensure-collection) ] keep ] unless - [ mdb-instance name>> ] dip "%s.%s" sprintf ; + [let* | instance [ mdb-instance ] + instance-name [ instance name>> ] | + dup mdb-collection? [ name>> ] when + "." split1 over instance-name = + [ nip ] [ drop ] if + [ ] [ reserved-namespace? ] bi + [ instance (ensure-collection) ] unless + [ instance-name ] dip 2array "." join ] ; : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 60b2d25764..6c2b89a571 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence ) : user-defined-key-index ( class -- assoc ) mdb-slot-map user-defined-key [ drop [ "user-defined-key-index" 1 ] dip - H{ } clone [ set-at ] keep unique-index + H{ } clone [ set-at ] keep t >>unique? [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; From b1e91e10e625fe7790ed6c1ed75c9a27e613a435 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 23 Jun 2009 13:58:20 +0200 Subject: [PATCH 31/49] changed single byte writes to write1 --- extra/bson/writer/writer.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index 5d850929ab..f9bd0eb392 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -75,24 +75,23 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline -: write-byte ( byte -- ) CHAR-SIZE >le write ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline -: write-eoo ( -- ) T_EOO write-byte ; inline -: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-eoo ( -- ) T_EOO write1 ; inline +: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline M: string bson-write ( obj -- ) '[ _ write-cstring ] with-length-prefix-excl ; M: f bson-write ( f -- ) - drop 0 write-byte ; + drop 0 write1 ; M: t bson-write ( t -- ) - drop 1 write-byte ; + drop 1 write1 ; M: integer bson-write ( num -- ) write-int32 ; @@ -105,7 +104,7 @@ M: timestamp bson-write ( timestamp -- ) M: byte-array bson-write ( binary -- ) [ length write-int32 ] keep - T_Binary_Bytes write-byte + T_Binary_Bytes write1 write ; M: oid bson-write ( oid -- ) @@ -134,7 +133,7 @@ M: assoc bson-write ( assoc -- ) : (serialize-code) ( code -- ) object>bytes [ length write-int32 ] keep - T_Binary_Custom write-byte + T_Binary_Custom write1 write ; M: quotation bson-write ( quotation -- ) From 15c7499ef500597ee6d8851a210826d550b8723d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 06:41:51 -0500 Subject: [PATCH 32/49] alien.libraries: add dispose method for library tuple, and remove-library word; add-library first calls remove-library to properly close the library when reloading --- basis/alien/libraries/libraries-docs.factor | 13 +++++++++---- basis/alien/libraries/libraries.factor | 14 +++++++++++--- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor index eac7655c38..a23a00b502 100755 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.syntax assocs help.markup -help.syntax io.backend kernel namespaces ; +help.syntax io.backend kernel namespaces strings ; IN: alien.libraries HELP: @@ -15,7 +15,7 @@ HELP: libraries { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; HELP: library -{ $values { "name" "a string" } { "library" assoc } } +{ $values { "name" string } { "library" assoc } } { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $list { { $snippet "name" } " - the full path of the C library binary" } @@ -40,11 +40,11 @@ HELP: dlclose ( dll -- ) { $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ; HELP: load-library -{ $values { "name" "a string" } { "dll" "a DLL handle" } } +{ $values { "name" string } { "dll" "a DLL handle" } } { $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ; HELP: add-library -{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } +{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } { $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." } { $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work." $nl @@ -59,9 +59,14 @@ $nl } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; +HELP: remove-library +{ $values { "name" string } } +{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ; + ARTICLE: "loading-libs" "Loading native libraries" "Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:" { $subsection add-library } +{ $subsection remove-library } "Once a library has been defined, you can try loading it to see if the path name is correct:" { $subsection load-library } "If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ; diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 0b39bedadd..b2ce66b02c 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.strings assocs io.backend kernel namespaces ; +USING: accessors alien alien.strings assocs io.backend +kernel namespaces destructors ; IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; @@ -21,5 +22,12 @@ TUPLE: library path abi dll ; : load-library ( name -- dll ) library dup [ dll>> ] when ; -: add-library ( name path abi -- ) - swap libraries get set-at ; \ No newline at end of file +M: dll dispose dlclose ; + +M: library dispose dll>> [ dispose ] when* ; + +: remove-library ( name -- ) + libraries get delete-at* [ dispose ] [ drop ] if ; + +: add-library ( name path abi -- ) + swap libraries get [ delete-at ] [ set-at ] 2bi ; \ No newline at end of file From baff251d1e5ccd233a73159fedf4965307d5ef61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 06:51:31 -0500 Subject: [PATCH 33/49] alien.libraries: add remove-library word, fix dlclose and dll-valid? VM primitives --- basis/alien/libraries/libraries-tests.factor | 10 ++++++++++ core/alien/alien-tests.factor | 4 ---- vm/alien.cpp | 11 ++++++----- 3 files changed, 16 insertions(+), 9 deletions(-) create mode 100644 basis/alien/libraries/libraries-tests.factor diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor new file mode 100644 index 0000000000..13eb134ea9 --- /dev/null +++ b/basis/alien/libraries/libraries-tests.factor @@ -0,0 +1,10 @@ +IN: alien.libraries.tests +USING: alien.libraries alien.syntax tools.test kernel ; + +[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test + +[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test + +[ ] [ "doesnotexist" dlopen dlclose ] unit-test + +[ "fdasfsf" dll-valid? drop ] must-fail \ No newline at end of file diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index d3265f31bb..2d2cec168f 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -71,10 +71,6 @@ cell 8 = [ [ "( displaced alien )" ] [ 0 B{ 1 2 3 } unparse ] unit-test -[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test - -[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test - SYMBOL: initialize-test f initialize-test set-global diff --git a/vm/alien.cpp b/vm/alien.cpp index 49afd608ec..13764a8e50 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -134,20 +134,21 @@ PRIMITIVE(dlsym) box_alien(ffi_dlsym(NULL,sym)); else { - tagged d = library.as(); - d.untag_check(); + dll *d = untag_check(library.value()); if(d->dll == NULL) dpush(F); else - box_alien(ffi_dlsym(d.untagged(),sym)); + box_alien(ffi_dlsym(d,sym)); } } /* close a native library handle */ PRIMITIVE(dlclose) { - ffi_dlclose(untag_check(dpop())); + dll *d = untag_check(dpop()); + if(d->dll != NULL) + ffi_dlclose(d); } PRIMITIVE(dll_validp) @@ -156,7 +157,7 @@ PRIMITIVE(dll_validp) if(library == F) dpush(T); else - dpush(tagged(library)->dll == NULL ? F : T); + dpush(untag_check(library)->dll == NULL ? F : T); } /* gets the address of an object representing a C pointer */ From 92b0765cd7519ffbb9c700f5d36a5a7d0cd2baa4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 06:58:47 -0500 Subject: [PATCH 34/49] contributors: exclude merges to make patch counts more reasonable --- extra/contributors/contributors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 73bee76c0a..97f4edc521 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -7,7 +7,7 @@ IN: contributors : changelog ( -- authors ) image parent-directory [ - "git log --pretty=format:%an" ascii stream-lines + "git log --no-merges --pretty=format:%an" ascii stream-lines ] with-directory ; : patch-counts ( authors -- assoc ) From 9bba898dfb2b81090ef6f838ac31614b3558187c Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 9 Jul 2009 14:16:19 +0200 Subject: [PATCH 35/49] replace 2array "." join with "." glue --- extra/mongodb/connection/connection.factor | 8 ++++---- extra/mongodb/driver/driver.factor | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index af54f2ebc5..45cced5b3b 100644 --- a/extra/mongodb/connection/connection.factor +++ b/extra/mongodb/connection/connection.factor @@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; mdb-connection get instance>> ; inline : index-collection ( -- ns ) - mdb-instance name>> "system.indexes" 2array "." join ; inline + mdb-instance name>> "system.indexes" "." glue ; inline : namespaces-collection ( -- ns ) - mdb-instance name>> "system.namespaces" 2array "." join ; inline + mdb-instance name>> "system.namespaces" "." glue ; inline : cmd-collection ( -- ns ) - mdb-instance name>> "$cmd" 2array "." join ; inline + mdb-instance name>> "$cmd" "." glue ; inline : index-ns ( colname -- index-ns ) - [ mdb-instance name>> ] dip 2array "." join ; inline + [ mdb-instance name>> ] dip "." glue ; inline : send-message ( message -- ) [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 48f0aef4ff..92ad770e20 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -125,7 +125,7 @@ M: mdb-collection create-collection : ensure-valid-collection-name ( collection -- ) [ ";$." intersect length 0 > ] keep - '[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline + '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline : build-collection-map ( -- assoc ) H{ } clone load-collection-list @@ -154,7 +154,7 @@ M: mdb-collection create-collection [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ instance (ensure-collection) ] unless - [ instance-name ] dip 2array "." join ] ; + [ instance-name ] dip "." glue ] ; : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline From 69c82bc98070a0f8befad1507c3ff228ff4938ad Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 10 Jul 2009 01:00:06 +0200 Subject: [PATCH 36/49] FUEL: Font lock/indentation for M::. --- misc/fuel/fuel-syntax.el | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 3fc16e7af6..a4559c5c5c 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -54,7 +54,8 @@ "HELP:" "HEX:" "HOOK:" "IN:" "initial:" "INSTANCE:" "INTERSECTION:" "LIBRARY:" - "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:" + "M:" "M::" "MACRO:" "MACRO::" "MAIN:" "MATH:" + "MEMO:" "MEMO:" "METHOD:" "MIXIN:" "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" "QUALIFIED-WITH:" "QUALIFIED:" @@ -83,7 +84,7 @@ (format "%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) (defconst fuel-syntax--method-definition-regex - "^M: +\\([^ ]+\\) +\\([^ ]+\\)") + "^M::? +\\([^ ]+\\) +\\([^ ]+\\)") (defconst fuel-syntax--integer-regex "\\_<-?[0-9]+\\_>") @@ -154,7 +155,7 @@ "C-ENUM" "C-STRUCT" "C-UNION" "FROM" "FUNCTION:" "INTERSECTION:" - "M" "MACRO" "MACRO:" + "M" "M:" "MACRO" "MACRO:" "MEMO" "MEMO:" "METHOD" "SYNTAX" "PREDICATE" "PRIMITIVE" @@ -215,7 +216,9 @@ (format ":[^ ]* \\([^ ]+\\)\\(%s\\)*" fuel-syntax--stack-effect-regex)) (defconst fuel-syntax--defun-signature-regex - (format "\\(%s\\|%s\\)" fuel-syntax--word-signature-regex "M[^:]*: [^ ]+ [^ ]+")) + (format "\\(%s\\|%s\\)" + fuel-syntax--word-signature-regex + "M[^:]*: [^ ]+ [^ ]+")) (defconst fuel-syntax--constructor-decl-regex "\\_ Date: Thu, 9 Jul 2009 19:02:15 -0500 Subject: [PATCH 37/49] Fixing some test failures after url.encoding change --- basis/farkup/farkup-tests.factor | 2 +- basis/http/client/client-tests.factor | 2 ++ basis/http/http-tests.factor | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 7d9c900ec2..863dc522b2 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -128,7 +128,7 @@ link-no-follow? off [ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test -[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test [ "

<foo>

" ] [ "" convert-farkup ] unit-test diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 4f786cb22c..c391b417a9 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -16,6 +16,7 @@ namespaces urls ; { version "1.1" } { cookies V{ } } { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } + { redirects 10 } } ] [ "http://www.apple.com/index.html" @@ -29,6 +30,7 @@ namespaces urls ; { version "1.1" } { cookies V{ } } { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } + { redirects 10 } } ] [ "https://www.amazon.com/index.html" diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index f11aa9eaa2..3fe5e84abd 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -33,6 +33,7 @@ blah { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } } { post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } } { cookies V{ } } + { redirects 10 } } ] [ read-request-test-1 lf>crlf [ @@ -70,6 +71,7 @@ Host: www.sex.com { version "1.1" } { header H{ { "host" "www.sex.com" } } } { cookies V{ } } + { redirects 10 } } ] [ read-request-test-2 lf>crlf [ From 8008bfb1f98659b32b55dc7956ebbfad33455498 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 19:10:36 -0500 Subject: [PATCH 38/49] Remove unused vocabulary --- .../propagate/propagate.factor | 69 ------------------- .../cfg/value-numbering/propagate/summary.txt | 1 - 2 files changed, 70 deletions(-) delete mode 100644 basis/compiler/cfg/value-numbering/propagate/propagate.factor delete mode 100644 basis/compiler/cfg/value-numbering/propagate/summary.txt diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor deleted file mode 100644 index d5c9830c0b..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences kernel accessors -compiler.cfg.instructions compiler.cfg.value-numbering.graph ; -IN: compiler.cfg.value-numbering.propagate - -! If two vregs compute the same value, replace references to -! the latter with the former. - -: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline - -GENERIC: propagate ( insn -- insn ) - -M: ##effect propagate - [ resolve ] change-src ; - -M: ##unary propagate - [ resolve ] change-src ; - -M: ##binary propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##binary-imm propagate - [ resolve ] change-src1 ; - -M: ##slot propagate - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##slot-imm propagate - [ resolve ] change-obj ; - -M: ##set-slot propagate - call-next-method - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##string-nth propagate - [ resolve ] change-obj - [ resolve ] change-index ; - -M: ##set-slot-imm propagate - call-next-method - [ resolve ] change-obj ; - -M: ##alien-getter propagate - call-next-method - [ resolve ] change-src ; - -M: ##alien-setter propagate - call-next-method - [ resolve ] change-value ; - -M: ##conditional-branch propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##compare-imm-branch propagate - [ resolve ] change-src1 ; - -M: ##dispatch propagate - [ resolve ] change-src ; - -M: ##fixnum-overflow propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/propagate/summary.txt b/basis/compiler/cfg/value-numbering/propagate/summary.txt deleted file mode 100644 index fd56a8e099..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Propagation pass to update code after value numbering From bb701bed7e417316e6009fc54629b7c28ee0578b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Jul 2009 19:50:15 -0500 Subject: [PATCH 39/49] Revert "Remove unused vocabulary" -- committed patch from the wrong machine This reverts commit 04c3c15411ae33d967f5aacf762f7200ac98c5aa. --- .../propagate/propagate.factor | 69 +++++++++++++++++++ .../cfg/value-numbering/propagate/summary.txt | 1 + 2 files changed, 70 insertions(+) create mode 100644 basis/compiler/cfg/value-numbering/propagate/propagate.factor create mode 100644 basis/compiler/cfg/value-numbering/propagate/summary.txt diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor new file mode 100644 index 0000000000..d5c9830c0b --- /dev/null +++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs sequences kernel accessors +compiler.cfg.instructions compiler.cfg.value-numbering.graph ; +IN: compiler.cfg.value-numbering.propagate + +! If two vregs compute the same value, replace references to +! the latter with the former. + +: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline + +GENERIC: propagate ( insn -- insn ) + +M: ##effect propagate + [ resolve ] change-src ; + +M: ##unary propagate + [ resolve ] change-src ; + +M: ##binary propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + +M: ##binary-imm propagate + [ resolve ] change-src1 ; + +M: ##slot propagate + [ resolve ] change-obj + [ resolve ] change-slot ; + +M: ##slot-imm propagate + [ resolve ] change-obj ; + +M: ##set-slot propagate + call-next-method + [ resolve ] change-obj + [ resolve ] change-slot ; + +M: ##string-nth propagate + [ resolve ] change-obj + [ resolve ] change-index ; + +M: ##set-slot-imm propagate + call-next-method + [ resolve ] change-obj ; + +M: ##alien-getter propagate + call-next-method + [ resolve ] change-src ; + +M: ##alien-setter propagate + call-next-method + [ resolve ] change-value ; + +M: ##conditional-branch propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + +M: ##compare-imm-branch propagate + [ resolve ] change-src1 ; + +M: ##dispatch propagate + [ resolve ] change-src ; + +M: ##fixnum-overflow propagate + [ resolve ] change-src1 + [ resolve ] change-src2 ; + +M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/propagate/summary.txt b/basis/compiler/cfg/value-numbering/propagate/summary.txt new file mode 100644 index 0000000000..fd56a8e099 --- /dev/null +++ b/basis/compiler/cfg/value-numbering/propagate/summary.txt @@ -0,0 +1 @@ +Propagation pass to update code after value numbering From 8281c2fb55c3a7652051f8f0361a8dc4fa375203 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 12:45:27 +1200 Subject: [PATCH 40/49] alien.inline.compile: write library files to resource:alien-inline-libs --- basis/alien/inline/compiler/compiler.factor | 15 ++++++++++----- basis/alien/inline/inline.factor | 2 +- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index b1ccc2baab..d049668eec 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -2,12 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators fry generalizations io.encodings.ascii io.files io.files.temp io.launcher kernel -locals make sequences system vocabs.parser words ; +locals make sequences system vocabs.parser words io.directories +io.pathnames ; IN: alien.inline.compiler SYMBOL: C SYMBOL: C++ +: inline-libs-directory ( -- path ) + "alien-inline-libs" resource-path dup make-directories ; + +: inline-library-file ( name -- path ) + inline-libs-directory prepend-path ; + : library-suffix ( -- str ) os { { [ dup macosx? ] [ drop ".dylib" ] } @@ -16,10 +23,8 @@ SYMBOL: C++ } cond ; : library-path ( str -- str' ) - '[ - "lib-" % current-vocab name>> % - "-" % _ % library-suffix % - ] "" make temp-file ; + '[ "lib" % "-" % _ % library-suffix % ] + "" make inline-library-file ; : src-suffix ( lang -- str ) { diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 88cc5e3519..8ec0952c5a 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -58,7 +58,7 @@ SYMBOL: c-strings PRIVATE> : define-c-library ( name -- ) - c-library set + [ current-vocab name>> % "_" % % ] "" make c-library set V{ } clone c-strings set V{ } clone compiler-args set ; From 59f0dbb5167a66aa95bbb164438ef4ed6ff690f6 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 13:14:43 +1200 Subject: [PATCH 41/49] alien.inline: fix library name and us remove-library --- basis/alien/inline/compiler/compiler.factor | 3 +-- basis/alien/inline/inline.factor | 8 ++++++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index d049668eec..d7d2d6fc43 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -23,8 +23,7 @@ SYMBOL: C++ } cond ; : library-path ( str -- str' ) - '[ "lib" % "-" % _ % library-suffix % ] - "" make inline-library-file ; + '[ "lib" % _ % library-suffix % ] "" make temp-file ; : src-suffix ( lang -- str ) { diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 8ec0952c5a..20ccd43e5c 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -55,10 +55,13 @@ SYMBOL: c-strings compiler-args get c-strings get "\n" join c-library get compile-to-library ; + +: c-library-name ( name -- name' ) + [ current-vocab name>> % "_" % % ] "" make ; PRIVATE> : define-c-library ( name -- ) - [ current-vocab name>> % "_" % % ] "" make c-library set + c-library-name c-library set V{ } clone c-strings set V{ } clone compiler-args set ; @@ -104,7 +107,8 @@ PRIVATE> ] 3bi ; : delete-inline-library ( str -- ) - library-path dup exists? [ delete-file ] [ drop ] if ; + c-library-name [ remove-library ] + [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ; SYNTAX: C-LIBRARY: scan define-c-library ; From 2e7f337b3dd6d750f139b40d1dec871aa0220031 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 23:53:50 +1200 Subject: [PATCH 42/49] alien.inline: made define-c-function and define-c-function' standalone --- basis/alien/inline/inline.factor | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 20ccd43e5c..2c0825f8b4 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -39,8 +39,8 @@ SYMBOL: c-strings : prototype-string' ( function types return -- str ) [ dup arg-list ] prototype-string ; -: append-function-body ( prototype-str -- str ) - " {\n" append parse-here append "\n}\n" append ; +: append-function-body ( prototype-str body -- str ) + [ swap % " {\n" % % "\n}\n" % ] "" make ; : compile-library? ( -- ? ) c-library get library-path dup exists? [ @@ -69,14 +69,18 @@ PRIVATE> compile-library? [ compile-library ] when c-library get dup library-path "cdecl" add-library ; -: define-c-function ( function types effect -- ) - [ factor-function define-declared ] 3keep prototype-string - append-function-body c-strings get push ; +: define-c-function ( function types effect body -- ) + [ + [ factor-function define-declared ] + [ prototype-string ] 3bi + ] dip append-function-body c-strings get push ; -: define-c-function' ( function effect -- ) - [ in>> ] keep [ factor-function define-declared ] 3keep - out>> prototype-string' - append-function-body c-strings get push ; +: define-c-function' ( function effect body -- ) + [ + [ in>> ] keep + [ factor-function define-declared ] + [ out>> prototype-string' ] 3bi + ] dip append-function-body c-strings get push ; : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -123,7 +127,7 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ; SYNTAX: C-INCLUDE: scan define-c-include ; SYNTAX: C-FUNCTION: - function-types-effect define-c-function ; + function-types-effect parse-here define-c-function ; SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; From 0851823ba92428e7ac57c8ecc6c12ba20d87aac1 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 23:54:40 +1200 Subject: [PATCH 43/49] alien.inline: remove vocab argument from define-c-struct --- basis/alien/inline/inline.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 2c0825f8b4..7f530bc64b 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -100,15 +100,15 @@ PRIVATE> "" make c-strings get push ] 2bi ; -: define-c-struct ( name vocab fields -- ) - [ define-struct ] [ - nip over +: define-c-struct ( name fields -- ) + [ current-vocab swap define-struct ] [ + over [ "typedef struct " % "_" % % " {\n" % [ first2 swap % " " % % ";\n" % ] each "} " % % ";\n" % ] "" make c-strings get push - ] 3bi ; + ] 2bi ; : delete-inline-library ( str -- ) c-library-name [ remove-library ] @@ -132,7 +132,7 @@ SYNTAX: C-FUNCTION: SYNTAX: C-TYPEDEF: scan scan define-c-typedef ; SYNTAX: C-STRUCTURE: - scan current-vocab parse-definition define-c-struct ; + scan parse-definition define-c-struct ; SYNTAX: ;C-LIBRARY compile-c-library ; From 864a6e75080785aca83be7bd0fb93e72d6795a67 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 23:55:05 +1200 Subject: [PATCH 44/49] alien.inline: better names --- basis/alien/inline/inline.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 7f530bc64b..37e01b5209 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -82,16 +82,16 @@ PRIVATE> [ out>> prototype-string' ] 3bi ] dip append-function-body c-strings get push ; -: define-c-link ( str -- ) +: c-link-to ( str -- ) "-l" prepend compiler-args get push ; -: define-c-framework ( str -- ) +: c-use-framework ( str -- ) "-framework" swap compiler-args get '[ _ push ] bi@ ; -: define-c-link/framework ( str -- ) - os macosx? [ define-c-framework ] [ define-c-link ] if ; +: c-link-to/use-framework ( str -- ) + os macosx? [ c-use-framework ] [ c-link-to ] if ; -: define-c-include ( str -- ) +: c-include ( str -- ) "#include " prepend c-strings get push ; : define-c-typedef ( old new -- ) @@ -110,7 +110,7 @@ PRIVATE> ] "" make c-strings get push ] 2bi ; -: delete-inline-library ( str -- ) +: delete-inline-library ( name -- ) c-library-name [ remove-library ] [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ; @@ -118,13 +118,13 @@ SYNTAX: C-LIBRARY: scan define-c-library ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; -SYNTAX: C-LINK: scan define-c-link ; +SYNTAX: C-LINK: scan c-link-to ; -SYNTAX: C-FRAMEWORK: scan define-c-framework ; +SYNTAX: C-FRAMEWORK: scan c-use-framework ; -SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ; +SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ; -SYNTAX: C-INCLUDE: scan define-c-include ; +SYNTAX: C-INCLUDE: scan c-include ; SYNTAX: C-FUNCTION: function-types-effect parse-here define-c-function ; From dc80d8575f0f3ac124876c870afd59e31d5d4a42 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Fri, 10 Jul 2009 23:55:32 +1200 Subject: [PATCH 45/49] alien.inline: added documentation --- basis/alien/inline/inline-docs.factor | 205 ++++++++++++++++++++++++++ 1 file changed, 205 insertions(+) create mode 100644 basis/alien/inline/inline-docs.factor diff --git a/basis/alien/inline/inline-docs.factor b/basis/alien/inline/inline-docs.factor new file mode 100644 index 0000000000..bce3f2530c --- /dev/null +++ b/basis/alien/inline/inline-docs.factor @@ -0,0 +1,205 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel strings effects ; +IN: alien.inline + +: $binding-note ( x -- ) + drop + { "This word requires that certain variables are correctly bound. " + "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ; + +HELP: ;C-LIBRARY +{ $syntax ";C-LIBRARY" } +{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." } +{ $see-also POSTPONE: compile-c-library } ; + +HELP: C-FRAMEWORK: +{ $syntax "C-FRAMEWORK: name" } +{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-use-framework } ; + +HELP: C-FUNCTION: +{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" } +{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." } +{ $examples + { $example + "USING: alien.inline prettyprint ;" + "IN: cmath.ffi" + "" + "C-LIBRARY: cmathlib" + "" + "C-FUNCTION: int add ( int a, int b )" + " return a + b;" + ";" + "" + ";C-LIBRARY" + "" + "1 2 add ." + "3" } +} +{ $see-also POSTPONE: define-c-function } ; + +HELP: C-INCLUDE: +{ $syntax "C-INCLUDE: name" } +{ $description "Appends an include line to the C library in scope." } +{ $see-also POSTPONE: c-include } ; + +HELP: C-LIBRARY: +{ $syntax "C-LIBRARY: name" } +{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." } +{ $examples + { $example + "USING: alien.inline ;" + "IN: rectangle.ffi" + "" + "C-LIBRARY: rectlib" + "" + "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;" + "" + "C-FUNCTION: int area ( rectangle c )" + " return c.width * c.height;" + ";" + "" + ";C-LIBRARY" + "" } +} +{ $see-also POSTPONE: define-c-library } ; + +HELP: C-LINK/FRAMEWORK: +{ $syntax "C-LINK/FRAMEWORK: name" } +{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." } +{ $see-also POSTPONE: c-link-to/use-framework } ; + +HELP: C-LINK: +{ $syntax "C-LINK: name" } +{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." } +{ $see-also POSTPONE: c-link-to } ; + +HELP: C-STRUCTURE: +{ $syntax "C-STRUCTURE: name pairs ... ;" } +{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."} +{ $see-also POSTPONE: define-c-struct } ; + +HELP: C-TYPEDEF: +{ $syntax "C-TYPEDEF: old new" } +{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." } +{ $see-also POSTPONE: define-c-typedef } ; + +HELP: COMPILE-AS-C++ +{ $syntax "COMPILE-AS-C++" } +{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ; + +HELP: DELETE-C-LIBRARY: +{ $syntax "DELETE-C-LIBRARY: name" } +{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " } +{ $notes + { $list + { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } + "This word is mainly useful for unit tests." + } +} +{ $see-also POSTPONE: delete-inline-library } ; + +HELP: RAW-C: +{ $syntax "RAW-C:" "body" ";" } +{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ; + +CONSTANT: foo "abc" + +HELP: compile-c-library +{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". " + "Also calls " { $snippet "add-library" } ". " + "This word does nothing if the shared library is younger than the factor source file." } +{ $notes $binding-note } ; + +HELP: c-use-framework +{ $values + { "str" string } +} +{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." } +{ $notes $binding-note } +{ $see-also c-link-to c-link-to/use-framework } ; + +HELP: define-c-function +{ $values + { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string } +} +{ $description "Defines a C function and a factor word which calls it." } +{ $notes + { $list + { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." } + { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." } + $binding-note + } +} +{ $see-also POSTPONE: define-c-function' } ; + +HELP: define-c-function' +{ $values + { "function" "function name" } { "effect" effect } { "body" string } +} +{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." } +{ $notes + { $list + { "Each effect element must be a legal C type with dashes (-) instead of spaces. " + "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." } + $binding-note + } +} +{ $see-also define-c-function } ; + +HELP: c-include +{ $values + { "str" string } +} +{ $description "Appends an include line to the C library in scope." } +{ $notes $binding-note } ; + +HELP: define-c-library +{ $values + { "name" string } +} +{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ; + +HELP: c-link-to +{ $values + { "str" string } +} +{ $description "Adds " { $snippet "-lname" } " to linker command." } +{ $notes $binding-note } +{ $see-also c-use-framework c-link-to/use-framework } ; + +HELP: c-link-to/use-framework +{ $values + { "str" string } +} +{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." } +{ $notes $binding-note } +{ $see-also c-link-to c-use-framework } ; + +HELP: define-c-struct +{ $values + { "name" string } { "fields" "type/name pairs" } +} +{ $description "Defines a C struct and factor words which operate on it." } +{ $notes $binding-note } ; + +HELP: define-c-typedef +{ $values + { "old" "C type" } { "new" "C type" } +} +{ $description "Define C and factor typedefs." } +{ $notes $binding-note } ; + +HELP: delete-inline-library +{ $values + { "name" string } +} +{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." } +{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ; + +ARTICLE: "alien.inline" "Inline C" +{ $vocab-link "alien.inline" } +; + +ABOUT: "alien.inline" From 4a5cb3aac3f2b85818a74fbc3bf18acd6f2ba4a4 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 00:08:40 +1200 Subject: [PATCH 46/49] alien.inline: added with-c-library word --- basis/alien/inline/inline-docs.factor | 8 +++++++- basis/alien/inline/inline.factor | 10 +++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/basis/alien/inline/inline-docs.factor b/basis/alien/inline/inline-docs.factor index bce3f2530c..58eca558ea 100644 --- a/basis/alien/inline/inline-docs.factor +++ b/basis/alien/inline/inline-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel strings effects ; +USING: help.markup help.syntax kernel strings effects quotations ; IN: alien.inline : $binding-note ( x -- ) @@ -198,6 +198,12 @@ HELP: delete-inline-library { $description "Delete the shared library file corresponding to " { $snippet "name" } "." } { $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ; +HELP: with-c-library +{ $values + { "name" string } { "quot" quotation } +} +{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ; + ARTICLE: "alien.inline" "Inline C" { $vocab-link "alien.inline" } ; diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 37e01b5209..1df77d6600 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -6,7 +6,7 @@ generalizations grouping io.directories io.files io.files.info io.files.temp kernel lexer math math.order math.ranges multiline namespaces sequences source-files splitting strings system vocabs.loader vocabs.parser words -alien.c-types alien.structs make parser ; +alien.c-types alien.structs make parser continuations ; IN: alien.inline c-library-name [ remove-library ] [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ; +: with-c-library ( name quot -- ) + [ [ define-c-library ] dip call compile-c-library ] + [ cleanup-variables ] [ ] cleanup ; inline + SYNTAX: C-LIBRARY: scan define-c-library ; SYNTAX: COMPILE-AS-C++ t library-is-c++ set ; From b03b76996615a3e984e57b13d523f3901ba4cde1 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 19:23:21 +1200 Subject: [PATCH 47/49] alien.inline: renamed compiler-args to linker-args --- basis/alien/inline/inline.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index 1df77d6600..1b1820779c 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -12,11 +12,11 @@ IN: alien.inline : define-c-library ( name -- ) c-library-name c-library set V{ } clone c-strings set - V{ } clone compiler-args set ; + V{ } clone linker-args set ; : compile-c-library ( -- ) compile-library? [ compile-library ] when @@ -87,10 +87,10 @@ PRIVATE> ] dip append-function-body c-strings get push ; : c-link-to ( str -- ) - "-l" prepend compiler-args get push ; + "-l" prepend linker-args get push ; : c-use-framework ( str -- ) - "-framework" swap compiler-args get '[ _ push ] bi@ ; + "-framework" swap linker-args get '[ _ push ] bi@ ; : c-link-to/use-framework ( str -- ) os macosx? [ c-use-framework ] [ c-link-to ] if ; From eb72ba84f613ae5e5d3be6d018e33fdf3832558f Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 19:23:49 +1200 Subject: [PATCH 48/49] alien.inline.compiler: fixed library-path and made other words private --- basis/alien/inline/compiler/compiler.factor | 25 ++++++++++++--------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor index d7d2d6fc43..4abc78ff67 100644 --- a/basis/alien/inline/compiler/compiler.factor +++ b/basis/alien/inline/compiler/compiler.factor @@ -22,14 +22,8 @@ SYMBOL: C++ { [ dup windows? ] [ drop ".dll" ] } } cond ; -: library-path ( str -- str' ) - '[ "lib" % _ % library-suffix % ] "" make temp-file ; - -: src-suffix ( lang -- str ) - { - { C [ ".c" ] } - { C++ [ ".cpp" ] } - } case ; +: library-path ( str -- path ) + '[ "lib" % _ % library-suffix % ] "" make inline-library-file ; HOOK: compiler os ( lang -- str ) @@ -59,8 +53,16 @@ M: macosx link-descr { "-g" "-prebind" "-dynamiclib" "-o" } cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ; -: link-command ( in out lang -- descr ) - compiler-descr link-descr append prepend prepend ; + :: compile-to-library ( lang args contents name -- ) lang contents name compile-to-object From f2380aab7fc0f86fb0ee0f90ffd36d9ba71e76a3 Mon Sep 17 00:00:00 2001 From: Jeremy Hughes Date: Sat, 11 Jul 2009 19:24:09 +1200 Subject: [PATCH 49/49] alien.inline.compiler: documentation --- .../inline/compiler/compiler-docs.factor | 77 +++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 basis/alien/inline/compiler/compiler-docs.factor diff --git a/basis/alien/inline/compiler/compiler-docs.factor b/basis/alien/inline/compiler/compiler-docs.factor new file mode 100644 index 0000000000..28e2538e1f --- /dev/null +++ b/basis/alien/inline/compiler/compiler-docs.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel strings words.symbol sequences ; +IN: alien.inline.compiler + +HELP: C +{ $var-description "A symbol representing C source." } ; + +HELP: C++ +{ $var-description "A symbol representing C++ source." } ; + +HELP: compile-to-library +{ $values + { "lang" symbol } { "args" sequence } { "contents" string } { "name" string } +} +{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" } + "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. " + { $snippet "args" } " is a sequence of arguments for the linking stage." } +{ $notes + { $list + "C and C++ are the only supported languages." + { "Source and object files are placed in " { $snippet "resource:temp" } "." } } +} ; + +HELP: compiler +{ $values + { "lang" symbol } + { "str" string } +} +{ $description "Returns a compiler name based on OS and source language." } +{ $see-also compiler-descr } ; + +HELP: compiler-descr +{ $values + { "lang" symbol } + { "descr" "a process description" } +} +{ $description "Returns a compiler process description based on OS and source language." } +{ $see-also compiler } ; + +HELP: inline-library-file +{ $values + { "name" string } + { "path" "a pathname string" } +} +{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ; + +HELP: inline-libs-directory +{ $values + { "path" "a pathname string" } +} +{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ; + +HELP: library-path +{ $values + { "str" string } + { "path" "a pathname string" } +} +{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ; + +HELP: library-suffix +{ $values + { "str" string } +} +{ $description "The appropriate shared library suffix for the current OS." } ; + +HELP: link-descr +{ $values + { "descr" sequence } +} +{ $description "Returns part of a process description. OS dependent." } ; + +ARTICLE: "alien.inline.compiler" "Inline C compiler" +{ $vocab-link "alien.inline.compiler" } +; + +ABOUT: "alien.inline.compiler"