From 16ba9fbd8041697a0b3f23ec3bb0117216759ec0 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Mon, 15 Jun 2009 17:09:20 +0900
Subject: [PATCH 01/39] 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 <matthew.willis@mac.com>
Date: Mon, 15 Jun 2009 21:39:40 +0900
Subject: [PATCH 02/39] 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 <matthew.willis@mac.com>
Date: Mon, 15 Jun 2009 21:42:13 +0900
Subject: [PATCH 03/39] 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" <module> [
+ {
+ { [ 32 LLVMIntType ] "add" }
+ { [ 32 LLVMIntType ] "x" }
+ { [ 32 LLVMIntType ] "y" }
+ } <function> [
+ "entry" <builder> [
+ builder value>> "x" get-param "y" get-param "sum" LLVMBuildAdd
+ builder value>> swap LLVMBuildRet drop
+ ] with-builder
+ ] with-function
+
+ <engine>
+ ] 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
+
+: <dispose> ( alien class -- disposable ) new swap >>value ;
+
+TUPLE: LLVMModule value disposed ;
+M: LLVMModule dispose* value>> LLVMDisposeModule ;
+
+: <module> ( name -- module )
+ LLVMModuleCreateWithName LLVMModule <dispose> ;
+
+TUPLE: LLVMModuleProvider value disposed ;
+M: LLVMModuleProvider dispose* value>> LLVMDisposeModuleProvider ;
+
+: <provider> ( -- module-provider )
+ module t >>disposed value>> LLVMCreateModuleProviderForExistingModule
+ LLVMModuleProvider <dispose> ;
+
+: (add-block) ( name -- basic-block )
+ function swap LLVMAppendBasicBlock ;
+
+TUPLE: LLVMBuilder value disposed ;
+M: LLVMBuilder dispose* value>> LLVMDisposeBuilder ;
+
+: <builder> ( name -- builder )
+ (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
+ LLVMBuilder <dispose> ;
+
+TUPLE: LLVMExecutionEngine value disposed ;
+M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ;
+
+: <engine> ( -- engine )
+ <provider> [
+ dup value>> f <void*> f <void*>
+ [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
+ *void* [ llvm-throw ] when* *void* LLVMExecutionEngine <dispose>
+ swap t >>disposed drop
+ ] with-disposal ;
+
+: resolve-type ( callable/alien -- type )
+ dup callable? [ call( -- type ) ] when ;
+
+: <function-type> ( 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" <c-array> [ 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 ;
+
+: <function> ( args -- function )
+ module value>> over first second pick
+ [ first ] map <function-type> 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 <void*> [ 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 <matthew.willis@mac.com>
Date: Mon, 15 Jun 2009 21:46:19 +0900
Subject: [PATCH 04/39] 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 <matthew.willis@mac.com>
Date: Tue, 16 Jun 2009 08:53:16 +0900
Subject: [PATCH 05/39] 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 <void*> [ 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 <void*> [ LLVMFindFunction drop ] keep *void* ;
\ No newline at end of file
From 27e95c7908049884ead0b65f4fdf56d982a213e1 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Tue, 16 Jun 2009 09:15:24 +0900
Subject: [PATCH 06/39] 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 <matthew.willis@mac.com>
Date: Tue, 16 Jun 2009 09:19:50 +0900
Subject: [PATCH 07/39] 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 <alfredo.beaumont@gmail.com>
Date: Thu, 18 Jun 2009 20:47:08 +0200
Subject: [PATCH 08/39] 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
-
<PRIVATE
: write-request-line ( request -- request )
@@ -79,7 +77,7 @@ SYMBOL: redirects
:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
- redirects get max-redirects < [
+ redirects get request get redirects>> < [
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: <response>
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 <matthew.willis@mac.com>
Date: Mon, 22 Jun 2009 21:21:15 +0900
Subject: [PATCH 09/39] 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 <matthew.willis@mac.com>
Date: Fri, 26 Jun 2009 00:21:54 +0900
Subject: [PATCH 10/39] 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> 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 ;
+: <pointer> ( t -- o ) pointer new swap >>type ;
+
+M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
+M: pointer clean* type>> clean ;
+
+TUPLE: vector < enclosing size type ;
+: <vector> ( 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? ;
+: <struct> ( 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 ;
+: <array> ( 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? ;
+: <function> ( 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> 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 <integer> ]]
+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 <pointer> ]]
+Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
+StructureTypesList = "," Type:t => [[ t ]]
+Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
+Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
+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 <function> ]]
+PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
+UpReference = "\\" Number:n => [[ n <up-ref> ]]
+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 <matthew.willis@mac.com>
Date: Fri, 26 Jun 2009 22:00:55 +0900
Subject: [PATCH 11/39] 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 <matthew.willis@mac.com>
Date: Fri, 26 Jun 2009 22:01:20 +0900
Subject: [PATCH 12/39] 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> 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: <up-ref>
+:: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
+ ref types get index
+ [ types get length swap - <up-ref> ] [
+ 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 ;
: <pointer> ( 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 ;
: <vector> ( 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? ;
: <struct> ( 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 <void*-array>
+ [ LLVMGetStructElementTypes ] keep >array
+ [ (tref>) ] map >>types ;
TUPLE: array < enclosing size type ;
: <array> ( 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 <void*-array>
+ [ 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> 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 <integer> ]]
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 <pointer> ]]
Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
From 48863ca17100a6a53eb1e5bc32f5fbf09dae88ae Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Sat, 27 Jun 2009 18:41:40 +0900
Subject: [PATCH 13/39] 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" <module> [ <provider> ] 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" <module> [
+ <provider>
+ ] with-disposal [
+ <engine>
+ ] with-disposal ;
+
+: <jit> ( -- 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 <void*> f <void*>
+ [ 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 [ <jit> ] 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" <module> dispose ] unit-test
+[ ] [ "test" <module> [ <provider> ] with-disposal dispose ] unit-test
+[ ] [ "llvm.jit" vocabs member? [ "test" <module> [ <provider> ] with-disposal [ <engine> ] 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 ;
+
+: <dispose> ( alien class -- disposable ) new swap >>value ;
+
+TUPLE: module value disposed ;
+M: module dispose* value>> LLVMDisposeModule ;
+
+: <module> ( name -- module )
+ LLVMModuleCreateWithName module <dispose> ;
+
+TUPLE: provider value disposed ;
+M: provider dispose* value>> LLVMDisposeModuleProvider ;
+
+: <provider> ( 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 <dispose> ;
+
+TUPLE: engine value disposed ;
+M: engine dispose* value>> LLVMDisposeExecutionEngine ;
+
+: <engine> ( provider -- engine )
+ [
+ value>> f <void*> f <void*>
+ [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ ]
+ [ t >>disposed drop ] bi
+ engine <dispose> ;
+
+: (add-block) ( name -- basic-block )
+ "function" swap LLVMAppendBasicBlock ;
+
+TUPLE: builder value disposed ;
+M: builder dispose* value>> LLVMDisposeBuilder ;
+
+: <builder> ( name -- builder )
+ (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
+ builder <dispose> ;
\ No newline at end of file
From c843edd87003c2e823b114df199552681dac7733 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Tue, 30 Jun 2009 11:43:04 +0900
Subject: [PATCH 14/39] 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 <void*-array>
+ [ LLVMGetParams ] keep >array
+ [ [ LLVMGetValueName ] [ LLVMTypeOf tref> ] bi 2array ] map ;
+
+: <function> ( 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 [ <function> ] map ;
+
+: function-effect ( function -- effect )
+ [ params>> [ first ] map ] [ void? 0 1 ? ] bi <effect> ;
+
+: 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" <module> [ <provider> ] with-disposal [ "test" add-provider ] with-disposal "test" remove-provider ] unit-test
\ No newline at end of file
+[ ] [ "test" <module> "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" <module> [
- <provider>
- ] with-disposal [
- <engine>
- ] with-disposal ;
+ "initial-module" <module> <provider> <engine> ;
: <jit> ( -- 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 <void*> f <void*>
[ 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 -- )
+ [ <provider> ] 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 <void*> [ LLVMFindFunction drop ] keep
+ *void* LLVMGetPointerToGlobal ;
thejit [ <jit> ] 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*tN01Z<i8vp<R
literal 0
HcmV?d00001
diff --git a/extra/llvm/reader/add.ll b/extra/llvm/reader/add.ll
new file mode 100644
index 0000000000..4ac57a2af3
--- /dev/null
+++ b/extra/llvm/reader/add.ll
@@ -0,0 +1,5 @@
+define i32 @add(i32 %x, i32 %y) {
+entry:
+ %sum = add i32 %x, %y
+ ret i32 %sum
+}
diff --git a/extra/llvm/reader/reader.factor b/extra/llvm/reader/reader.factor
new file mode 100644
index 0000000000..8ff6d50e96
--- /dev/null
+++ b/extra/llvm/reader/reader.factor
@@ -0,0 +1,18 @@
+USING: accessors alien.c-types alien.syntax destructors kernel
+llvm.core llvm.engine llvm.jit llvm.wrappers ;
+
+IN: llvm.reader
+
+: buffer>module ( buffer -- module )
+ [
+ value>> f <void*> f <void*>
+ [ LLVMParseBitcode drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ module new swap >>value
+ ] with-disposal ;
+
+: load-module ( path -- module )
+ <buffer> 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" <module> dispose ] unit-test
-[ ] [ "test" <module> [ <provider> ] with-disposal dispose ] unit-test
-[ ] [ "llvm.jit" vocabs member? [ "test" <module> [ <provider> ] with-disposal [ <engine> ] with-disposal dispose ] unless ] unit-test
\ No newline at end of file
+[ ] [ "test" <module> <provider> dispose ] unit-test
+[ ] [ "llvm.jit" vocabs member? [ "test" <module> <provider> <engine> 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 ;
: <dispose> ( alien class -- disposable ) new swap >>value ;
@@ -14,21 +15,21 @@ M: module dispose* value>> LLVMDisposeModule ;
: <module> ( name -- module )
LLVMModuleCreateWithName module <dispose> ;
-TUPLE: provider value disposed ;
+TUPLE: provider value module disposed ;
M: provider dispose* value>> LLVMDisposeModuleProvider ;
-: <provider> ( 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 <dispose> ;
+: (provider) ( module -- provider )
+ [ value>> LLVMCreateModuleProviderForExistingModule provider <dispose> ]
+ [ t >>disposed value>> ] bi
+ >>module ;
+
+: <provider> ( module -- provider )
+ [ (provider) ] with-disposal ;
TUPLE: engine value disposed ;
M: engine dispose* value>> LLVMDisposeExecutionEngine ;
-: <engine> ( provider -- engine )
+: (engine) ( provider -- engine )
[
value>> f <void*> f <void*>
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
@@ -37,6 +38,9 @@ M: engine dispose* value>> LLVMDisposeExecutionEngine ;
[ t >>disposed drop ] bi
engine <dispose> ;
+: <engine> ( provider -- engine )
+ [ (engine) ] with-disposal ;
+
: (add-block) ( name -- basic-block )
"function" swap LLVMAppendBasicBlock ;
@@ -45,4 +49,12 @@ M: builder dispose* value>> LLVMDisposeBuilder ;
: <builder> ( name -- builder )
(add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
- builder <dispose> ;
\ No newline at end of file
+ builder <dispose> ;
+
+TUPLE: buffer value disposed ;
+M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
+
+: <buffer> ( path -- module )
+ f <void*> f <void*>
+ [ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
+ *void* [ llvm-throw ] when* *void* buffer <dispose> ;
\ No newline at end of file
From 1716a4bec8bf8b76852aa49761b542959561ff3e Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Tue, 30 Jun 2009 11:57:24 +0900
Subject: [PATCH 15/39] 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" <module> [
- {
- { [ 32 LLVMIntType ] "add" }
- { [ 32 LLVMIntType ] "x" }
- { [ 32 LLVMIntType ] "y" }
- } <function> [
- "entry" <builder> [
- builder value>> "x" get-param "y" get-param "sum" LLVMBuildAdd
- builder value>> swap LLVMBuildRet drop
- ] with-builder
- ] with-function
-
- <engine>
- ] 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
-
-: <dispose> ( alien class -- disposable ) new swap >>value ;
-
-TUPLE: LLVMModule value disposed ;
-M: LLVMModule dispose* value>> LLVMDisposeModule ;
-
-: <module> ( name -- module )
- LLVMModuleCreateWithName LLVMModule <dispose> ;
-
-TUPLE: LLVMModuleProvider value disposed ;
-M: LLVMModuleProvider dispose* value>> LLVMDisposeModuleProvider ;
-
-: <provider> ( -- module-provider )
- module t >>disposed value>> LLVMCreateModuleProviderForExistingModule
- LLVMModuleProvider <dispose> ;
-
-: (add-block) ( name -- basic-block )
- function swap LLVMAppendBasicBlock ;
-
-TUPLE: LLVMBuilder value disposed ;
-M: LLVMBuilder dispose* value>> LLVMDisposeBuilder ;
-
-: <builder> ( name -- builder )
- (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
- LLVMBuilder <dispose> ;
-
-TUPLE: LLVMExecutionEngine value disposed ;
-M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ;
-
-: <engine> ( -- engine )
- <provider> [
- dup value>> f <void*> f <void*>
- [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
- *void* [ llvm-throw ] when* *void* LLVMExecutionEngine <dispose>
- swap t >>disposed drop
- ] with-disposal ;
-
-: resolve-type ( callable/alien -- type )
- dup callable? [ call( -- type ) ] when ;
-
-: <function-type> ( 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" <c-array> [ 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 ;
-
-: <function> ( args -- function )
- module value>> over first second pick
- [ first ] map <function-type> 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 <void*> [ LLVMFindFunction drop ] keep *void* ;
\ No newline at end of file
From d4c03d84598ff2ca252b7bb25fea11bace7cb54c Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Tue, 30 Jun 2009 11:58:09 +0900
Subject: [PATCH 16/39] 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 <matthew.willis@mac.com>
Date: Tue, 30 Jun 2009 22:55:20 +0900
Subject: [PATCH 17/39] 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 [ <function> ] map ;
: function-effect ( function -- effect )
- [ params>> [ first ] map ] [ void? 0 1 ? ] bi <effect> ;
+ [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
: 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> 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 <integer> = "char*" "void*" ? ;
TUPLE: vector < enclosing size type ;
: <vector> ( s t -- o )
From c1d08d213fdbaeb74a5631faa899cc12fd21687a Mon Sep 17 00:00:00 2001
From: Phil Dawes <phil@phildawes.net>
Date: Tue, 30 Jun 2009 16:26:51 +0100
Subject: [PATCH 18/39] 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 <matthew.willis@mac.com>
Date: Wed, 1 Jul 2009 11:08:57 +0900
Subject: [PATCH 19/39] 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" <module> "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" <module> 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 <matthew.willis@mac.com>
Date: Wed, 1 Jul 2009 14:52:15 +0900
Subject: [PATCH 20/39] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Jul 2009 23:07:06 -0500
Subject: [PATCH 21/39] 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>> <spill-slot> ] [ 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 <spill-slot> ]
+ [ reg-class>> ]
+ tri \ register->memory boa
+ ] [
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ 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 <spill-slot> ]
- [ reg-class>> ]
- tri \ register->memory boa
- ] [
- [ reg-class>> spill-temp <spill-slot> ]
- [ 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 <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Jul 2009 23:28:28 -0500
Subject: [PATCH 22/39] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 00:20:03 -0500
Subject: [PATCH 23/39] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 00:48:00 -0500
Subject: [PATCH 24/39] 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 <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 02:28:30 -0500
Subject: [PATCH 25/39] 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: <literal-info>
[ read-only>> [ <literal-info> ] [ 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 <literal-info> >>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 <byte-array> length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 f <string> 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" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 9 Jul 2009 06:17:10 -0500
Subject: [PATCH 26/39] 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 <slava@shill.local>
Date: Thu, 9 Jul 2009 06:31:38 -0500
Subject: [PATCH 27/39] 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 <process-reader> f swap stream-read-until drop ;
From 097487a9f3cee148a31a2a233ec112c2a0882c1d Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Fri, 3 Jul 2009 08:18:49 +0200
Subject: [PATCH 28/39] 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 <sascha.matzke@didolo.org>
Date: Mon, 6 Jul 2009 09:05:20 +0200
Subject: [PATCH 29/39] 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 <sascha.matzke@didolo.org>
Date: Sun, 5 Jul 2009 13:28:41 +0200
Subject: [PATCH 30/39] 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 <index-spec> unique-index ensure-index ;
+ "_x_idx" [ "x" asc ] key-spec <index-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 <mdb>"
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
{ $unchecked-example "USING: mongodb.driver ;"
- "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+ "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> 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 <mdb-db>
[ verify-nodes ] keep ;
-GENERIC: create-collection ( name -- )
+GENERIC: create-collection ( name/collection -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection
- [ cmd-collection ] dip
- <linked-hash> [
- [ [ 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 <mdb-query-msg> 1 >>return# send-query-plain drop ;
-
+ [ [ cmd-collection ] dip
+ <linked-hash> [ make-collection-assoc ] keep
+ <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
+ [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+
: load-collection-list ( -- collection-list )
namespaces-collection
H{ } clone <mdb-query-msg> 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 <mdb-collection> ] 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 <mdb-collection> ] 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 <tuple-index> unique-index
+ H{ } clone [ set-at ] keep <tuple-index> 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 <sascha.matzke@didolo.org>
Date: Tue, 23 Jun 2009 13:58:20 +0200
Subject: [PATCH 31/39] 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 <slava@shill.local>
Date: Thu, 9 Jul 2009 06:41:51 -0500
Subject: [PATCH 32/39] 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: <library>
@@ -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 -- )
- <library> 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 -- )
+ <library> 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 <slava@shill.local>
Date: Thu, 9 Jul 2009 06:51:31 -0500
Subject: [PATCH 33/39] 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 } <displaced-alien> 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<dll> d = library.as<dll>();
- d.untag_check();
+ dll *d = untag_check<dll>(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<dll>(dpop()));
+ dll *d = untag_check<dll>(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<dll>(library)->dll == NULL ? F : T);
+ dpush(untag_check<dll>(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 <slava@shill.local>
Date: Thu, 9 Jul 2009 06:58:47 -0500
Subject: [PATCH 34/39] 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 <process-reader> stream-lines
+ "git log --no-merges --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ;
: patch-counts ( authors -- assoc )
From 9bba898dfb2b81090ef6f838ac31614b3558187c Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Thu, 9 Jul 2009 14:16:19 +0200
Subject: [PATCH 35/39] 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" <jao@gnu.org>
Date: Fri, 10 Jul 2009 01:00:06 +0200
Subject: [PATCH 36/39] 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
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
From c4f4c6749ff091767c1d514454bbfb296ee93eba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Thu, 9 Jul 2009 19:02:15 -0500
Subject: [PATCH 37/39] 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
[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
-[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+[ "<p><a href=\"C%2B%2B\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p><foo></p>" ] [ "<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 <slava@shill.local>
Date: Thu, 9 Jul 2009 19:10:36 -0500
Subject: [PATCH 38/39] 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 <slava@shill.local>
Date: Thu, 9 Jul 2009 19:50:15 -0500
Subject: [PATCH 39/39] 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