Changeset 12813 in project for chicken/trunk
- Timestamp:
- 12/12/08 14:14:35 (12 years ago)
- Location:
- chicken/trunk
- Files:
-
- 1 added
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/trunk/TODO
r12786 r12813 13 13 *** when re-defining intrinsics, the compiler should warn and disable re-writes 14 14 add declaration to keep re-writes enabled for core library files 15 *** check in foreign.import.scm and compiler.import.scm whether the import 16 took place in the compiler 15 17 16 18 ** expander … … 149 151 ** libraries/build 150 152 *** check use of paths with windows builds: proper handling of quoting and 151 slashe don all shell configurations?153 slashes on all shell configurations? 152 154 153 155 … … 179 181 180 182 ** compiler 183 *** test define-rewrite-rule 184 **** use declarative interface? 181 185 *** generate object-files in /tmp (or TMPDIR)? 182 186 … … 203 207 *** rules.make should really be generated by a script 204 208 *** need script to process import libraries for generating indices for doc.callcc.org 205 then tell Toby about it209 then tell Toby Butzon about it 206 210 207 211 … … 232 236 ** compiler-support for get-keyword ? 233 237 234 ** lambda-fusion / "fuse-and-dispatch" (suggested by Alex )238 ** lambda-fusion / "fuse-and-dispatch" (suggested by Alex Shinn) 235 239 convert groups of local lambdas referenced to only in operator-position into 236 240 looping lambda + dispatch (static variable can be used), otherwise similar to … … 238 242 *** new forms (after optimization, prepared language) 239 243 [##core#dispatch LAMBDABODY1 ... BODY] 240 [##core#call/dispatch {INDEX} ARGUMENT1 ...} 244 [##core#goto {INDEX} ARGUMENT1 ...} 245 246 ** lazy gensyms (see "lazy-gensyms" branch) 241 247 242 248 ** handle optional args primitively -
chicken/trunk/batch-driver.scm
r12803 r12813 34 34 compiler 35 35 compiler-arguments process-command-line dump-nodes dump-undefined-globals 36 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 37 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 38 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 36 default-standard-bindings default-extended-bindings 37 foldable-bindings 39 38 compiler-cleanup-hook disabled-warnings local-definitions inline-output-file 40 39 file-io-only undefine-shadowed-macros profiled-procedures -
chicken/trunk/c-backend.scm
r12631 r12813 31 31 (private compiler 32 32 compiler-arguments process-command-line find-early-refs 33 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 34 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings 35 foldable-extended-bindings 36 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 33 default-standard-bindings default-extended-bindings 34 foldable-bindings 37 35 installation-home optimization-iterations debugging cleanup 38 36 file-io-only -
chicken/trunk/c-platform.scm
r12789 r12813 31 31 (private compiler 32 32 compiler-arguments process-command-line 33 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 34 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 35 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 33 default-standard-bindings default-extended-bindings 34 foldable-bindings non-foldable-bindings 36 35 installation-home debugging intrinsic? 37 36 dump-nodes unlikely-variables … … 197 196 ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) ) 198 197 199 (define side-effecting-standard-bindings 200 '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display 198 (define non-foldable-bindings 199 '(vector 200 cons list string make-vector make-string string->symbol values current-input-port current-output-port 201 read-char write-char 202 apply call-with-current-continuation set-car! set-cdr! write-char newline write display 201 203 peek-char char-ready? 202 204 read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file 203 205 open-output-file close-input-port close-output-port call-with-input-port call-with-output-port 204 call-with-values eval) ) 205 206 (define non-foldable-standard-bindings 207 '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port 208 read-char write-char) ) 209 210 (define foldable-standard-bindings 211 (lset-difference 212 eq? default-standard-bindings 213 side-effecting-standard-bindings non-foldable-standard-bindings) ) 214 215 (define non-foldable-extended-bindings 216 '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void 206 call-with-values eval 207 ##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void 217 208 u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared 218 209 f32vector->blob/shared f64vector->blob/shared … … 226 217 ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) ) 227 218 228 (define foldable-extended-bindings 229 (lset-difference 230 eq? default-extended-bindings non-foldable-extended-bindings) ) 231 232 (define standard-bindings-that-never-return-false 233 '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer 234 integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min 235 quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin 236 cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string 237 string->list list->string vector->list list->vector read-char substring make-string make-vector 238 open-input-file open-output-file vector write-char) ) 239 240 (define side-effect-free-standard-bindings-that-never-return-false 241 (lset-difference 242 eq? standard-bindings-that-never-return-false 243 side-effecting-standard-bindings) ) 219 (define foldable-bindings 220 (lset-difference 221 eq? 222 (lset-union eq? default-standard-bindings default-extended-bindings) 223 non-foldable-bindings) ) 244 224 245 225 -
chicken/trunk/chicken-syntax.scm
r12632 r12813 1072 1072 1073 1073 1074 ;;; just in case someone forgets1074 ;;; Just in case someone forgets 1075 1075 1076 1076 (##sys#extend-macro-environment -
chicken/trunk/chicken.scm
r12559 r12813 34 34 (private compiler 35 35 compiler-arguments 36 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 37 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 38 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 36 default-standard-bindings default-extended-bindings 37 foldable-bindings 39 38 installation-home optimization-iterations process-command-line 40 39 file-io-only nonwinding-call/cc debugging -
chicken/trunk/compiler.scm
r12610 r12813 88 88 ; ##compiler#profile -> BOOL 89 89 ; ##compiler#unused -> BOOL 90 ; ##compiler#foldable -> BOOL 90 91 91 92 ; - Source language: … … 141 142 ; (define-compiled-syntax (<symbol> . <llist>) <expr> ...) 142 143 ; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>) 144 ; (##core#define-rewrite-rule <symbol> <expr>) 143 145 144 146 ; - Core language: … … 219 221 ; potential-value -> <node> Global variable was assigned this value 220 222 ; references -> (<node> ...) Nodes that are accesses of this variable (##core#variable nodes) 221 ; side-effecting -> <boolean> If true: variable names side-effecting standard-binding222 ; foldable -> <boolean> If true: variable names foldable standard-binding223 223 ; boxed -> <boolean> If true: variable has to be boxed after closure-conversion 224 224 ; contractable -> <boolean> If true: variable names contractable procedure … … 270 270 (private compiler 271 271 compiler-arguments process-command-line explicit-use-flag 272 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 273 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 274 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 272 default-standard-bindings default-extended-bindings 273 foldable-bindings 275 274 installation-home decompose-lambda-list external-to-pointer defconstant-bindings constant-declarations 276 275 copy-node! error-is-extended-binding toplevel-scope toplevel-lambda-id … … 293 292 perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub 294 293 expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive 295 process-declaration external-protos-first basic-literal? 294 process-declaration external-protos-first basic-literal? rewrite 296 295 transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker 297 296 debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list … … 789 788 ,body)) ;*** possibly wrong se? 790 789 se dest))) 790 791 ((##core#define-rewrite-rule) 792 (let ((name (##sys#strip-syntax (cadr x) se #t)) 793 (re (caddr x))) 794 (##sys#put! name '##compiler#intrinsic 'rewrite) 795 (rewrite 796 name 8 797 (eval/meta re)) 798 '(##core#undefined))) 791 799 792 800 ((##core#module) -
chicken/trunk/defaults.make
r12789 r12813 341 341 CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX) 342 342 IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras \ 343 regex srfi-14 tcp foreign scheme srfi-18 utils csi343 regex srfi-14 tcp foreign compiler scheme srfi-18 utils csi 344 344 IMPORT_LIBRARIES += setup-api setup-download 345 345 -
chicken/trunk/distribution/manifest
r12786 r12813 296 296 foreign.import.scm 297 297 foreign.import.c 298 compiler.import.scm 299 compiler.import.c 298 300 lolevel.import.scm 299 301 srfi-1.import.scm -
chicken/trunk/foreign.import.scm
r10754 r12813 1 ;;;; foreign.import.scm - import library for "foreign" module1 ;;;; foreign.import.scm - import library for "foreign" pseudo module 2 2 ; 3 3 ; Copyright (c) 2008, The Chicken Team -
chicken/trunk/optimizer.scm
r12301 r12813 30 30 (private compiler 31 31 compiler-arguments process-command-line perform-lambda-lifting! 32 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 33 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 34 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 32 default-standard-bindings default-extended-bindings 33 foldable-bindings 35 34 installation-home decompose-lambda-list external-to-pointer 36 35 copy-node! variable-visible? mark-variable intrinsic? … … 194 193 (let ((var (first (node-parameters (car subs))))) 195 194 (if (and (intrinsic? var) 196 ( test var 'foldable)195 (foldable? var) 197 196 (every constant-node? (cddr subs)) ) 198 197 (let ((form (cons var (map (lambda (arg) `(quote ,(node-value arg))) … … 491 490 (or (test 'not 'call-sites) '()) ) ) 492 491 493 ;; Handle '(if (<func> <a> ...) ...)', where <func> never returns false:494 (for-each495 (lambda (varname)496 (if (intrinsic? varname)497 (for-each498 (lambda (site)499 (let* ((n (cdr site))500 (subs (node-subexpressions n))501 (kont (first (node-parameters (second subs))))502 (krefs (test kont 'references))503 (lnode (and (not (test kont 'unknown)) (test kont 'value))) )504 ;; Call-site has side-effect-free arguments and a known continuation that has only one use?505 (if (and lnode506 (eq? '##core#lambda (node-class lnode))507 krefs (= 1 (length krefs))508 (not (any (lambda (sn) (expression-has-side-effects? sn db)) (cddr subs))) )509 (let* ((llist (third (node-parameters lnode)))510 (body (first (node-subexpressions lnode))) )511 ;; Continuation has one parameter and contains an 'if' node?512 (if (and (proper-list? llist)513 (null? (cdr llist))514 (eq? 'if (node-class body)) )515 (let* ((var (car llist))516 (refs (test var 'references))517 (iftest (first (node-subexpressions body))) )518 ;; Parameter is used only once and is the test-argument?519 (if (and refs (= 1 (length refs))520 (eq? '##core#variable (node-class iftest))521 (eq? var (first (node-parameters iftest))) )522 (let ((bodysubs (node-subexpressions body)))523 ;; Modify call-site to call continuation directly and swap branches524 ;; in the conditional:525 (debugging 'o "removed call in test-context" varname)526 (node-parameters-set! n '(#t))527 (node-subexpressions-set! n (list (second subs) (qnode #t)))528 (touch) ) ) ) ) ) ) ) )529 (or (test varname 'call-sites) '()) ) ) )530 side-effect-free-standard-bindings-that-never-return-false)531 532 492 (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots)) 533 493 dirty) ) -
chicken/trunk/rules.make
r12789 r12813 554 554 $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT) 555 555 foreign.import$(O): foreign.import.c chicken.h $(CHICKEN_CONFIG_H) 556 $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \ 557 $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \ 558 $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT) 559 compiler.import$(O): compiler.import.c chicken.h $(CHICKEN_CONFIG_H) 556 560 $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \ 557 561 $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \ … … 1105 1109 $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/tcp.import.so 1106 1110 $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/foreign.import.so 1111 $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/compiler.import.so 1107 1112 $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/scheme.import.so 1108 1113 $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/csi.import.so … … 1313 1318 foreign.import.c: $(SRCDIR)foreign.import.scm 1314 1319 $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@ 1320 compiler.import.c: $(SRCDIR)compiler.import.scm 1321 $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@ 1315 1322 scheme.import.c: $(SRCDIR)scheme.import.scm 1316 1323 $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@ -
chicken/trunk/support.scm
r12789 r12813 31 31 (private compiler 32 32 compiler-arguments process-command-line dump-nodes dump-undefined-globals 33 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 34 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 35 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 33 default-standard-bindings default-extended-bindings 34 foldable-bindings compiler-macro-environment 36 35 installation-home optimization-iterations compiler-cleanup-hook decompose-lambda-list 37 36 file-io-only banner disabled-warnings internal-bindings … … 323 322 ; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level 324 323 ; symbol-keyed hash-tables here. 324 ; - does currently nothing after the first invocation, but we leave it 325 ; this way to have the option to add default entries for each new db. 325 326 326 327 (define initialize-analysis-database 327 328 (let ((initial #t)) 328 329 (lambda (db) 329 (for-each 330 (lambda (s) 331 (when initial 332 (mark-variable s '##compiler#intrinsic 'standard)) 333 (when (memq s side-effecting-standard-bindings) (put! db s 'side-effecting #t)) 334 (when (memq s foldable-standard-bindings) (put! db s 'foldable #t)) ) 335 standard-bindings) 336 (for-each 337 (lambda (s) 338 (when initial 330 (when initial 331 (for-each 332 (lambda (s) 333 (mark-variable s '##compiler#intrinsic 'standard) 334 (when (memq s foldable-bindings) 335 (mark-variable s '##compiler#foldable #t))) 336 standard-bindings) 337 (for-each 338 (lambda (s) 339 339 (mark-variable s '##compiler#intrinsic 'extended)) 340 (when (memq s foldable-extended-bindings) (put! db s 'foldable #t)) ) 341 extended-bindings) 342 (when initial 340 extended-bindings) 343 341 (for-each 344 342 (lambda (s) … … 414 412 (define display-analysis-database 415 413 (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo) (assigned-locally . stl) 416 (contractable . con) (standard-binding . stb) ( foldable . fld) (simple . sim) (inlinable . inl)417 ( side-effecting . sef) (collapsable . col) (removable . rem) (constant . con)414 (contractable . con) (standard-binding . stb) (simple . sim) (inlinable . inl) 415 (collapsable . col) (removable . rem) (constant . con) 418 416 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx) 419 417 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) … … 438 436 (begin 439 437 (case (caar es) 440 ((captured assigned boxed global contractable standard-binding foldableassigned-locally441 side-effectingcollapsable removable undefined replacing unused simple inlinable inline-export438 ((captured assigned boxed global contractable standard-binding assigned-locally 439 collapsable removable undefined replacing unused simple inlinable inline-export 442 440 has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs) 443 441 (printf "\t~a" (cdr (assq (caar es) names))) ) … … 1481 1479 1482 1480 (define intrinsic? (cut variable-mark <> '##compiler#intrinsic)) 1481 (define foldable? (cut variable-mark <> '##compiler#foldable)) 1482 1483 1484 ;;; compiler-specific syntax 1485 1486 (define compiler-macro-environment 1487 (let ((me0 (##sys#macro-environment))) 1488 (##sys#extend-macro-environment 1489 'define-rewrite-rule 1490 '() 1491 (##sys#er-transformer 1492 (lambda (form r c) 1493 (##sys#check-syntax 'define-rewrite-rule form '(_ (symbol . _) . #(_ 1))) 1494 `(##core#define-rewrite-rule 1495 ,(caadr form) (,(r 'lambda) ,(cdadr form) ,@(cddr form)))))) 1496 (##sys#macro-subset me0)))
Note: See TracChangeset
for help on using the changeset viewer.