~ chicken-core (chicken-5) 91267288baf5dcc97c601807007488bfd61c76f6
commit 91267288baf5dcc97c601807007488bfd61c76f6
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Dec 5 21:30:57 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Dec 5 21:30:57 2009 +0100
incorporated unboxing patches
diff --git a/batch-driver.scm b/batch-driver.scm
index eaf460d9..d90d8eef 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -1,7 +1,7 @@
;;;; batch-driver.scm - Driver procedure for the compiler
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -54,42 +54,43 @@
arg) ) ) )
(initialize-compiler)
(set! explicit-use-flag (memq 'explicit-use options))
- (let ([initforms `((##core#declare
+ (let ((initforms `((##core#declare
,@(append
default-declarations
(if explicit-use-flag
'()
- `((uses ,@units-used-by-default)) ) ) ) ) ]
- [verbose (memq 'verbose options)]
- [outfile (cond [(memq 'output-file options)
+ `((uses ,@units-used-by-default)) ) ) ) ) )
+ (verbose (memq 'verbose options))
+ (outfile (cond ((memq 'output-file options)
=> (lambda (node)
- (let ([oname (option-arg node)])
+ (let ((oname (option-arg node)))
(if (symbol? oname)
(symbol->string oname)
- oname) ) ) ]
- [(memq 'to-stdout options) #f]
- [else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
- [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))]
- [opasses default-optimization-passes]
- [time0 #f]
- [time-breakdown #f]
- [forms '()]
- [cleanup-forms '(((##sys#implicit-exit-handler)))]
- [profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options))]
- [profile-name (or (and-let* ((pn (memq 'profile-name options))) (cadr pn)) default-profile-name)]
- [hsize (memq 'heap-size options)]
- [hisize (memq 'heap-initial-size options)]
- [hgrowth (memq 'heap-growth options)]
- [hshrink (memq 'heap-shrinkage options)]
- [kwstyle (memq 'keyword-style options)]
- [uses-units '()]
- [uunit (memq 'unit options)]
- [a-only (memq 'analyze-only options)]
- [dynamic (memq 'dynamic options)]
- [dumpnodes #f]
- [start-time #f]
+ oname) ) ) )
+ ((memq 'to-stdout options) #f)
+ (else (make-pathname #f (if filename (pathname-file filename) "out") "c")) ) )
+ (ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";")))
+ (opasses default-optimization-passes)
+ (time0 #f)
+ (time-breakdown #f)
+ (forms '())
+ (cleanup-forms '(((##sys#implicit-exit-handler))))
+ (profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options)))
+ (profile-name (or (and-let* ((pn (memq 'profile-name options))) (cadr pn)) default-profile-name))
+ (hsize (memq 'heap-size options))
+ (hisize (memq 'heap-initial-size options))
+ (hgrowth (memq 'heap-growth options))
+ (hshrink (memq 'heap-shrinkage options))
+ (kwstyle (memq 'keyword-style options))
+ (uses-units '())
+ (uunit (memq 'unit options))
+ (a-only (memq 'analyze-only options))
+ (dynamic (memq 'dynamic options))
+ (unbox (memq 'unboxing options))
+ (dumpnodes #f)
+ (start-time #f)
(upap #f)
- [ssize (or (memq 'nursery options) (memq 'stack-size options))] )
+ (ssize (or (memq 'nursery options) (memq 'stack-size options))) )
(define (cputime) (##sys#fudge 6))
@@ -571,15 +572,13 @@
(when (memq 's debugging-chicken) (print-program-statistics db))
- (cond [progress
+ (cond (progress
(debugging 'p "optimization pass" i)
-
(begin-time)
(receive (node2 progress-flag)
(perform-high-level-optimizations node2 db)
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
-
(cond [progress-flag (loop (add1 i) node2 #t)]
[(not inline-substitutions-enabled)
(debugging 'p "rewritings enabled...")
@@ -593,36 +592,41 @@
(let ([progress (transform-direct-lambdas! node2 db)])
(end-time "leaf routine optimization")
(loop (add1 i) node2 progress) ) ) ]
- [else (loop (add1 i) node2 #f)] ) ) ]
+ [else (loop (add1 i) node2 #f)] ) ) )
- [else
+ (else
(print-node "optimized" '|7| node2)
-
(when inline-output-file
(let ((f inline-output-file))
(dribble "Generating global inline file `~a' ..." f)
(emit-global-inline-file f db) ) )
-
(begin-time)
- (let ([node3 (perform-closure-conversion node2 db)])
- (end-time "closure conversion")
- (print-db "final-analysis" '|8| db i)
- (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
- (display "(don't worry - still compiling...)\n") )
- (when a-only (exit 0))
- (print-node "closure-converted" '|9| node3)
-
+ (set! node2 (perform-closure-conversion node2 db))
+ (end-time "closure conversion")
+ (print-db "final-analysis" '|8| db i)
+ (when (and ##sys#warnings-enabled
+ (> (- (cputime) start-time) funny-message-timeout))
+ (display "(don't worry - still compiling...)\n") )
+ (print-node "closure-converted" '|9| node2)
+ (when unbox
+ (debugging 'p "performing unboxing")
(begin-time)
- (receive (node literals lliterals lambdas)
- (prepare-for-code-generation node3 db)
- (end-time "preparation")
-
- (begin-time)
- (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
- (dribble "generating `~A' ..." outfile)
- (generate-code literals lliterals lambdas out filename dynamic db)
- (when outfile (close-output-port out)))
- (end-time "code generation")
- (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
- (compiler-cleanup-hook)
- (dribble "compilation finished.") ) ) ] ) ) ) ) ) ) ) ) ) )
+ (perform-unboxing! node2)
+ (end-time "unboxing")
+ (print-node "unboxing" '|U| node2) )
+ (when a-only (exit 0))
+ (begin-time)
+ (receive
+ (node literals lliterals lambdas)
+ (prepare-for-code-generation node2 db)
+ (end-time "preparation")
+ (begin-time)
+ (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
+ (dribble "generating `~A' ..." outfile)
+ (generate-code literals lliterals lambdas out filename dynamic db)
+ (when outfile (close-output-port out)))
+ (end-time "code generation")
+ (when (memq 't debugging-chicken)
+ (##sys#display-times (##sys#stop-timer)))
+ (compiler-cleanup-hook)
+ (dribble "compilation finished.") ) ) ) ) ) ) ) ) ) ) ) )
diff --git a/c-backend.scm b/c-backend.scm
index d8f3bd0e..cfbfa982 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1,7 +1,7 @@
;;; c-backend.scm - C-generating backend for the CHICKEN compiler
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -115,6 +115,13 @@
(loop (cdr bs) (add1 i) (sub1 count)) ]
[else (expr (car bs) i)] ) ) )
+ ((##core#let_unboxed)
+ (let ((name (first params)))
+ (gen #t name #\=)
+ (expr (first subs) i)
+ (gen #\;)
+ (expr (second subs) i)))
+
((##core#ref)
(gen "((C_word*)")
(expr (car subs) i)
@@ -360,12 +367,12 @@
(gen ");") )
((##core#inline)
- (gen "(C_word)" (first params) #\()
+ (gen (first params) #\()
(expr-args subs i)
(gen #\)) )
((##core#inline_allocate)
- (gen "(C_word)" (first params) "(&a," (length subs))
+ (gen (first params) "(&a," (length subs))
(if (pair? subs)
(begin
(gen #\,)
@@ -395,6 +402,19 @@
(expr (second subs) i)
(gen "),C_SCHEME_UNDEFINED)") ) )
+ ((##core#unboxed_ref)
+ (gen (first params)))
+
+ ((##core#unboxed_set!)
+ (gen #t (first params) #\=)
+ (expr (first subs) i)
+ (gen #\;) )
+
+ ((##core#inline_unboxed) ;XXX is this needed?
+ (gen (first params) "(")
+ (expr-args subs i)
+ (gen #\)))
+
((##core#switch)
(gen #t "switch(")
(expr (first subs) i)
@@ -419,7 +439,7 @@
(expr (third subs) i)
(gen #\)) )
- (else (bomb "bad form")) ) ) )
+ (else (bomb "bad form" (node-class n))) ) ) )
(define (expr-args args i)
(pair-for-each
@@ -705,29 +725,38 @@
(##sys#copy-bytes s s2 start 0 len)
s2) )
+ (define (utype t)
+ (case t
+ ((fix) "long")
+ ((flo) "double")
+ ((chr) "char")
+ ((ptr) "void *")
+ (else (bomb "invalid unboxed type" t))))
+
(define (procedures)
(for-each
(lambda (ll)
- (let* ([n (lambda-literal-argument-count ll)]
- [id (lambda-literal-id ll)]
- [rname (real-name id db)]
- [demand (lambda-literal-allocated ll)]
- [rest (lambda-literal-rest-argument ll)]
- [customizable (lambda-literal-customizable ll)]
- [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
- [nec (- n (if empty-closure 1 0))]
- [vlist0 (make-variable-list n "t")]
- [alist0 (make-argument-list n "t")]
- [varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,)]
- [arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,)]
- [external (lambda-literal-external ll)]
- [looping (lambda-literal-looping ll)]
- [direct (lambda-literal-direct ll)]
- [rest-mode (lambda-literal-rest-argument-mode ll)]
- [temps (lambda-literal-temporaries ll)]
- [topname (if unit-name
+ (let* ((n (lambda-literal-argument-count ll))
+ (id (lambda-literal-id ll))
+ (rname (real-name id db))
+ (demand (lambda-literal-allocated ll))
+ (rest (lambda-literal-rest-argument ll))
+ (customizable (lambda-literal-customizable ll))
+ (empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))
+ (nec (- n (if empty-closure 1 0)))
+ (vlist0 (make-variable-list n "t"))
+ (alist0 (make-argument-list n "t"))
+ (varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,))
+ (arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,))
+ (external (lambda-literal-external ll))
+ (looping (lambda-literal-looping ll))
+ (direct (lambda-literal-direct ll))
+ (rest-mode (lambda-literal-rest-argument-mode ll))
+ (temps (lambda-literal-temporaries ll))
+ (ubtemps (lambda-literal-unboxed-temporaries ll))
+ (topname (if unit-name
(string-append unit-name "_toplevel")
- "toplevel") ] )
+ "toplevel") ) )
(when empty-closure (debugging 'o "dropping unused closure argument" id))
(gen #t #t)
(gen "/* " (cleanup rname) " */" #t)
@@ -759,10 +788,15 @@
(gen #t "C_word tmp;")
(if rest
(gen #t "C_word t" n #\;) ; To hold rest-list if demand is met
- (do ([i n (add1 i)]
- [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )
- ((zero? j))
- (gen #t "C_word t" i #\;) ) )
+ (begin
+ (do ([i n (add1 i)]
+ [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )
+ ((zero? j))
+ (gen #t "C_word t" i #\;) )
+ (for-each
+ (lambda (ubt)
+ (gen #t (utype (cdr ubt)) #\space (car ubt) #\;))
+ ubtemps)))
(cond [(eq? 'toplevel id)
(let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
[llen (length literals)] )
diff --git a/c-platform.scm b/c-platform.scm
index 215acb88..cff469e0 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -1,7 +1,7 @@
;;;; c-platform.scm - Platform specific parameters and definitions
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -92,7 +92,7 @@
analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
- setup-mode) )
+ setup-mode unboxing) )
(define valid-compiler-options-with-argument
'(debug
diff --git a/chicken.h b/chicken.h
index cc7e6b89..86f63a95 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1070,7 +1070,7 @@ extern double trunc(double);
#define C_random_fixnum(n) C_fix((int)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
#define C_randomize(n) (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_block_size(x) C_fix(C_header_size(x))
-#define C_pointer_address(x) ((C_byte *)C_u_i_car(x))
+#define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
#define C_kontinue(k, r) ((C_proc2)(void *)C_u_i_car(k))(2, (k), (r))
@@ -1135,7 +1135,9 @@ extern double trunc(double);
# define C_a_i_cons(a, n, car, cdr) C_pair(a, car, cdr)
#endif /* __GNUC__ */
+#define C_a_i_flonum(ptr, i, n) C_flonum(ptr, n)
#define C_a_i_data_mpointer(ptr, n, x) C_mpointer(ptr, C_data_pointer(x))
+#define C_a_i_mpointer(ptr, n, x) C_mpointer(ptr, (x))
#define C_a_int_to_num(ptr, n, i) C_int_to_num(ptr, i)
#define C_a_unsigned_int_to_num(ptr, n, i) C_unsigned_int_to_num(ptr, i)
#define C_a_double_to_num(ptr, n) C_double_to_number(C_flonum(ptr, n))
@@ -1261,6 +1263,9 @@ extern double trunc(double);
# endif
#endif
+#define C_ub_i_flonum_plus(x, y) ((x) + (y))
+#define C_ub_i_flonum_times(x, y) ((x) * (y))
+
#define C_end_of_main
#if !defined(C_EMBEDDED) && !defined(C_SHARED)
diff --git a/chicken.scm b/chicken.scm
index e3fffd7f..c1b35473 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -1,7 +1,7 @@
;;;; chicken.scm - The CHICKEN Scheme compiler (loader/main-module)
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -27,7 +27,7 @@
(declare
(uses chicken-syntax srfi-1 srfi-4 utils files extras data-structures support
- compiler optimizer compiler-syntax scrutinizer driver platform backend
+ compiler optimizer unboxing compiler-syntax scrutinizer driver platform backend
srfi-69)
(compile-syntax) )
@@ -82,6 +82,7 @@
(let ([level (string->number (car rest))])
(case level
[(0) #f]
+ ;;XXX later add 'unboxing to -O2 and above
[(1)
(set! options (cons 'optimize-leaf-routines options)) ]
[(2)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 5945ea16..da51dcdc 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -222,6 +222,7 @@
perform-inlining!
perform-lambda-lifting!
perform-pre-optimization!
+ perform-unboxing!
posq
postponed-initforms
pprint-expressions-to-file
diff --git a/compiler.scm b/compiler.scm
index 4010ad8f..39236f86 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -5,8 +5,8 @@
;
;
;-----------------------------------------------------------------------------------------------------------
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -114,7 +114,7 @@
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
; (##core#primitive <name>)
-; (##core#inline <op> {<exp>})
+; (##core#inline {<op>} <exp>)
; (##core#inline_allocate (<op> <words>) {<exp>})
; (##core#inline_ref (<name> <type>))
; (##core#inline_update (<name> <type>) <exp>)
@@ -180,13 +180,17 @@
; [if {} <exp> <exp> <exp>]
; [quote {<exp>}]
; [##core#bind {<count>} <exp-v>... <exp>]
+; [##core#let_unboxed {<name> <utype>} <exp1> <exp2>]
; [##core#undefined {}]
+; [##core#unboxed_ref {<name> <utype>}]
+; [##core#unboxed_set! {<name> <utype>} <exp>]
; [##core#inline {<op>} <exp>...]
; [##core#inline_allocate {<op <words>} <exp>...]
; [##core#inline_ref {<name> <type>}]
; [##core#inline_update {<name> <type>} <exp>]
; [##core#inline_loc_ref {<type>} <exp>]
; [##core#inline_loc_update {<type>} <exp> <exp>]
+; [##core#inline_unboxed {<op>} <exp> ...]
; [##core#closure {<count>} <exp>...]
; [##core#box {} <exp>]
; [##core#unbox {} <exp>]
@@ -2368,16 +2372,17 @@
(define-record-type lambda-literal
(make-lambda-literal id external arguments argument-count rest-argument temporaries
- callee-signatures allocated directly-called closure-size
- looping customizable rest-argument-mode body direct)
+ unboxed-temporaries callee-signatures allocated directly-called
+ closure-size looping customizable rest-argument-mode body direct)
lambda-literal?
(id lambda-literal-id) ; symbol
(external lambda-literal-external) ; boolean
- (arguments lambda-literal-arguments) ; (symbol...)
+ (arguments lambda-literal-arguments) ; (symbol ...)
(argument-count lambda-literal-argument-count) ; integer
(rest-argument lambda-literal-rest-argument) ; symbol | #f
(temporaries lambda-literal-temporaries) ; integer
- (callee-signatures lambda-literal-callee-signatures) ; (integer...)
+ (unboxed-temporaries lambda-literal-unboxed-temporaries) ; ((sym . utype) ...)
+ (callee-signatures lambda-literal-callee-signatures) ; (integer ...)
(allocated lambda-literal-allocated) ; integer
(directly-called lambda-literal-directly-called) ; boolean
(closure-size lambda-literal-closure-size) ; integer
@@ -2388,16 +2393,17 @@
(direct lambda-literal-direct)) ; boolean
(define (prepare-for-code-generation node db)
- (let ([literals '()]
- [lambda-info-literals '()]
- [lambdas '()]
- [temporaries 0]
- [allocated 0]
- [looping 0]
- [signatures '()]
- [fastinits 0]
- [fastrefs 0]
- [fastsets 0] )
+ (let ((literals '())
+ (lambda-info-literals '())
+ (lambdas '())
+ (temporaries 0)
+ (ubtemporaries '())
+ (allocated 0)
+ (looping 0)
+ (signatures '())
+ (fastinits 0)
+ (fastrefs 0)
+ (fastsets 0) )
(define (walk-var var e sf)
(cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))]
@@ -2474,12 +2480,14 @@
subs) ) )
((##core#lambda ##core#direct_lambda)
- (let ([temps temporaries]
- [sigs signatures]
- [lping looping]
- [alc allocated]
- [direct (eq? class '##core#direct_lambda)] )
+ (let ((temps temporaries)
+ (ubtemps ubtemporaries)
+ (sigs signatures)
+ (lping looping)
+ (alc allocated)
+ (direct (eq? class '##core#direct_lambda)) )
(set! temporaries 0)
+ (set! ubtemporaries '())
(set! allocated 0)
(set! signatures '())
(set! looping 0)
@@ -2513,6 +2521,7 @@
argc
rest
(add1 temporaries)
+ ubtemporaries
signatures
allocated
(or direct (memq id direct-call-ids))
@@ -2529,6 +2538,7 @@
lambdas) )
(set! looping lping)
(set! temporaries temps)
+ (set! ubtemporaries ubtemps)
(set! allocated alc)
(set! signatures sigs)
(make-node '##core#proc (list (first params)) '()) ) ) ) ) )
@@ -2539,10 +2549,19 @@
[boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
(set! temporaries (add1 temporaries))
(make-node
- '##core#bind (list 1)
+ '##core#bind (list 1) ; is actually never used with more than 1 variable
(list (walk val e here boxes)
(walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) )
+ ((##core#let_unboxed)
+ (let* ((var (first params))
+ (val (first subs)) )
+ (set! ubtemporaries (alist-cons var (second params) ubtemporaries))
+ (make-node
+ '##core#let_unboxed params
+ (list (walk val e here boxes)
+ (walk (second subs) e here boxes) ) ) ) )
+
((set!)
(let ([var (first params)]
[val (first subs)] )
diff --git a/csc.scm b/csc.scm
index c06fce9e..78435789 100644
--- a/csc.scm
+++ b/csc.scm
@@ -1,7 +1,7 @@
;;;; csc.scm - Driver program for the CHICKEN compiler - felix -*- Scheme -*-
;
-; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -131,7 +131,7 @@
-analyze-only -keep-shadowed-macros -inline-global -ignore-repository
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
- -emit-all-import-libraries -setup-mode
+ -emit-all-import-libraries -setup-mode -unboxing
-no-procedure-checks-for-usual-bindings))
(define-constant complex-options
@@ -360,6 +360,7 @@ Usage: ~a FILENAME | OPTION ...
-inline enable inlining
-inline-limit set inlining threshold
-inline-global enable cross-module inlining
+ -unboxing use unboxed temporaries if possible
-n -emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
-consult-inline-file FILENAME explicitly load inline file
diff --git a/defaults.make b/defaults.make
index 720a5cd8..ecf464ba 100644
--- a/defaults.make
+++ b/defaults.make
@@ -270,6 +270,10 @@ APPLY_HACK_SRC ?= apply-hack.$(ARCH)$(ASM)
APPLY_HACK_OBJECT ?= apply-hack.$(ARCH)$(O)
endif
+ifeq ($(HACKED_APPLY),)
+APPLY_HACK_OBJECT =
+endif
+
# bootstrapping compiler
CHICKEN ?= chicken$(EXE)
diff --git a/distribution/manifest b/distribution/manifest
index 927073cd..7f0881f9 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -26,6 +26,7 @@ lolevel.c
optimizer.c
compiler-syntax.c
scrutinizer.c
+unboxing.c
regex.c
posixunix.c
posixwin.c
@@ -137,6 +138,7 @@ lolevel.scm
optimizer.scm
compiler-syntax.scm
scrutinizer.scm
+unboxing.scm
regex.scm
irregex.scm
posixunix.scm
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 2fdb5d77..1b9d3797 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -200,6 +200,8 @@ Possible options are:
; -to-stdout : Write compiled code to standard output instead of creating a {{.c}} file.
+; -unboxing : try to use unboxed temporaries for numerical operations.
+
; -unit NAME : Compile this file as a library unit. Equivalent to {{-prelude "(declare (unit NAME))"}}
; -unsafe : Disable runtime safety checks.
diff --git a/misc/compiler.files b/misc/compiler.files
index 58295742..9f4efd92 100644
--- a/misc/compiler.files
+++ b/misc/compiler.files
@@ -5,3 +5,5 @@ batch-driver.scm
c-backend.scm
c-platform.scm
chicken.scm
+scrutinizer.scm
+unboxing.scm
diff --git a/rules.make b/rules.make
index 716b18b6..d1830292 100644
--- a/rules.make
+++ b/rules.make
@@ -50,7 +50,7 @@ LIBCHICKENGUI_SHARED_OBJECTS = $(LIBCHICKENGUI_OBJECTS_1:=$(O))
LIBCHICKENGUI_STATIC_OBJECTS = $(LIBCHICKENGUI_OBJECTS_1:=-static$(O))
COMPILER_OBJECTS_1 = \
- chicken batch-driver compiler optimizer compiler-syntax scrutinizer support \
+ chicken batch-driver compiler optimizer compiler-syntax scrutinizer unboxing support \
c-platform c-backend
COMPILER_OBJECTS = $(COMPILER_OBJECTS_1:=$(O))
COMPILER_STATIC_OBJECTS = $(COMPILER_OBJECTS_1:=-static$(O))
@@ -587,6 +587,10 @@ scrutinizer$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
$(C_COMPILER_OUTPUT)
+unboxing$(O): unboxing.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
chicken$(O): chicken.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
@@ -638,6 +642,10 @@ scrutinizer-static$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_STATIC_OPTIONS) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+unboxing-static$(O): unboxing.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
# assembler objects
@@ -1191,6 +1199,9 @@ compiler-syntax.c: $(SRCDIR)compiler-syntax.scm $(SRCDIR)compiler-namespace.scm
scrutinizer.c: $(SRCDIR)scrutinizer.scm $(SRCDIR)compiler-namespace.scm \
$(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
$(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+unboxing.c: $(SRCDIR)unboxing.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)compiler-namespace.scm \
$(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
$(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
@@ -1238,7 +1249,7 @@ distfiles: library.c eval.c expand.c chicken-syntax.c \
usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
chicken-profile.c chicken-install.c chicken-uninstall.c chicken-status.c chicken-setup.c \
csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c \
- compiler-syntax.c scrutinizer.c support.c \
+ compiler-syntax.c scrutinizer.c unboxing.c support.c \
c-platform.c c-backend.c chicken-bug.c $(IMPORT_LIBRARIES:=.import.c)
dist: distfiles
@@ -1287,7 +1298,7 @@ spotless: distclean testclean
usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-bug.c \
csc.c csi.c chicken-install.c chicken-setup.c chicken-uninstall.c chicken-status.c \
chicken.c batch-driver.c compiler.c optimizer.c compiler-syntax.c \
- scrutinizer.c support.c \
+ scrutinizer.c support.c unboxing.c \
c-platform.c c-backend.c chicken-boot$(EXE) setup-api.c setup-download.c \
$(IMPORT_LIBRARIES:=.import.c)
diff --git a/support.scm b/support.scm
index 51493735..12252a9a 100644
--- a/support.scm
+++ b/support.scm
@@ -567,6 +567,8 @@
(loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
((##core#unbox ##core#ref ##core#update ##core#update_i)
(cons* class (walk (car subs)) params (map walk (cdr subs))) )
+ ((##core#inline_allocate ##core#let_unboxed)
+ (cons* class params (map walk subs)))
(else (cons class (append params (map walk subs)))) ) ) ) )
(define (fold-boolean proc lst)
@@ -1261,6 +1263,7 @@ Usage: chicken FILENAME OPTION ...
-inline enable inlining
-inline-limit set inlining threshold
-inline-global enable cross-module inlining
+ -unboxing use unboxed temporaries if possible
-emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
-consult-inline-file FILENAME explicitly load inline file
Trap