mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-07 01:40:41 -08:00
Code Issues Projects Releases Packages Wiki Activity

Simplifed MAKE-ARRAY. Deactivated the old garbage collector. New optimizers for MAKE-ARRAY and VECTOR-PUSH*. Declarations are now held in *cmp-env* instead of in global variables.

Browse source
This commit is contained in:
jgarcia 2008-05-18 20:08:39 +00:00
parent ab39a229f0
commit 8f28327ddf
18 changed files with 4474 additions and 4848 deletions
Download patch file Download diff file Expand all files Collapse all files

36
src/c/array.d
View file

@ -313,27 +313,37 @@ ecl_aset1(cl_object v, cl_index index, cl_object val)
/*
Internal function for making arrays of more than one dimension:
(si:make-pure-array element-type adjustable
displaced-to displaced-index-offset
dim0 dim1 ... )
(si:make-pure-array dimension-list element-type adjustable
displaced-to displaced-index-offset)
*/
@(defun si::make_pure_array (etype adj displ disploff &rest dims)
@ {
cl_object
si_make_pure_array(cl_object etype, cl_object dims, cl_object adj,
cl_object fillp, cl_object displ, cl_object disploff)
{
cl_index r, s, i, j;
cl_object x;
r = narg - 4;
if (FIXNUMP(dims)) {
return si_make_vector(etype, dims, adj, fillp, displ, disploff);
}
r = ecl_length(dims);
if (r >= ARANKLIM) {
FEerror("The array rank, ~R, is too large.", 1, MAKE_FIXNUM(r));
} else if (r == 1) {
return si_make_vector(etype, ECL_CONS_CAR(dims), adj, fillp,
displ, disploff);
} else if (!Null(fillp)) {
FEerror(":FILL-POINTER may not be specified for an array of rank ~D",
1, MAKE_FIXNUM(r));
}
x = cl_alloc_object(t_array);
x->array.displaced = Cnil;
x->array.self.t = NULL; /* for GC sake */
x->array.rank = r;
x->array.elttype = (short)ecl_symbol_to_elttype(etype);
x->array.dims = (cl_index *)cl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index));
if (r >= ARANKLIM) {
FEerror("The array rank, ~R, is too large.", 1, MAKE_FIXNUM(r));
}
for (i = 0, s = 1; i < r; i++) {
j = ecl_fixnum_in_range(@'make-array',"dimension",cl_va_arg(dims),
0,ADIMLIM);
for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) {
j = ecl_fixnum_in_range(@'make-array', "dimension",
ECL_CONS_CAR(dims), 0, ADIMLIM);
s *= (x->array.dims[i] = j);
if (s > ATOTLIM)
FEerror("The array total size, ~D, is too large.", 1, MAKE_FIXNUM(s));
@ -345,7 +355,7 @@ ecl_aset1(cl_object v, cl_index index, cl_object val)
else
displace(x, displ, disploff);
@(return x);
} @)
}
/*
Internal function for making vectors:

19
src/c/compiler.d
View file

@ -335,7 +335,8 @@ asm_op2c(register int code, register cl_object o) {
* (:function function-name) |
* (var-name {:special | nil} bound-p) |
* (symbol si::symbol-macro macro-function) |
* CB | LB | UNWIND-PROTECT
* CB | LB | UNWIND-PROTECT |
* (:declare declaration-arguments*)
* macro-record = (function-name function) |
* (macro-name si::macro macro-function)
* CB | LB | UNWIND-PROTECT
@ -347,6 +348,11 @@ asm_op2c(register int code, register cl_object o) {
* the variable-record corresponds just to a special declaration.
* CB, LB and UNWIND-PROTECT are only used by the C compiler and they
* denote closure, lexical environment and unwind-protect boundaries.
*
* The last variable records are devoted to declarations and are only
* used by the C compiler. Read cmpenv.lsp for more details on the
* structure of these declaration forms, as they do not completely
* match those of Common-Lisp.
*/
static void
@ -483,7 +489,8 @@ c_tag_ref(cl_object the_tag, cl_object the_type)
} else if (Null(name)) {
n++;
} else {
/* We are counting only locals and ignore specials */
/* We are counting only locals and ignore specials
* and other declarations */
}
}
return Cnil;
@ -500,9 +507,11 @@ c_var_ref(cl_object var, int allow_symbol_macro, bool ensure_defined)
continue;
name = CAR(record);
special = CADR(record);
if (name == @':block' || name == @':tag' || name == @':function')
if (name == @':block' || name == @':tag' || name == @':function') {
n++;
else if (name != var) {
} else if (name == @':declare') {
/* Ignored */
} else if (name != var) {
/* Symbol not yet found. Only count locals. */
if (Null(special)) n++;
} else if (special == @'si::symbol-macro') {
@ -600,6 +609,8 @@ c_undo_bindings(cl_object old_env)
FEerror("Internal error: cannot undo BLOCK/TAGBODY.",0);
} else if (name == @':function' || Null(special)) {
num_lexical++;
} else if (name == @':declare') {
/* Ignored */
} else if (special != @'si::symbol-macro') {
/* If (third special) = NIL, the variable was declared
special, but there is no binding! */

2
src/c/symbols_list.h
View file

@ -1131,7 +1131,7 @@ cl_symbols[] = {
{SYS_ "LOGICAL-PATHNAME-P", SI_ORDINARY, si_logical_pathname_p, 1, OBJNULL},
{SYS_ "MACRO", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "MAKE-LAMBDA", SI_ORDINARY, si_make_lambda, 2, OBJNULL},
{SYS_ "MAKE-PURE-ARRAY", SI_ORDINARY, si_make_pure_array, -1, OBJNULL},
{SYS_ "MAKE-PURE-ARRAY", SI_ORDINARY, si_make_pure_array, 6, OBJNULL},
{SYS_ "MAKE-STRING-OUTPUT-STREAM-FROM-STRING", SI_ORDINARY, si_make_string_output_stream_from_string, 1, OBJNULL},
{SYS_ "MAKE-STRUCTURE", SI_ORDINARY, si_make_structure, -1, OBJNULL},
{SYS_ "MAKE-VECTOR", SI_ORDINARY, si_make_vector, 6, OBJNULL},

84
src/cmp/cmparray.lsp Normal file
View file

@ -0,0 +1,84 @@
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; CMPARRAY. Optimizations related to arrays
;;;; Copyright (c) 2008. Juan Jose Garcia-Ripol
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
;;;
;;; MAKE-ARRAY
;;;
(define-compiler-macro make-array (&whole form dimensions &key (element-type t)
(initial-element nil initial-element-supplied-p)
(initial-contents nil initial-contents-supplied-p)
adjustable fill-pointer
displaced-to (displaced-index-offset 0)
&environment env)
;; This optimization is always done unless we provide content. There
;; is no speed, debug or space reason not to do it, unless the user
;; specifies not to inline MAKE-ARRAY, but in that case the compiler
;; macro should not be used.
(unless (or initial-element-supplied-p
initial-contents-supplied-p)
;; If the type is known and we can assume it will not change, we
;; replace it with the upgraded form.
(when (and (constantp element-type env)
(policy-assume-types-dont-change-p env))
(let ((new-type (cmp-eval element-type)))
(when (known-type-p new-type)
(setf element-type `',(upgraded-array-element-type new-type)))))
;; Finally, we choose between making a vector or making a general array.
;; It only saves some time, since MAKE-PURE-ARRAY will call MAKE-VECTOR
;; if a one-dimensional array is to be created.
(let ((function 'si::make-pure-array))
(when (constantp dimensions env)
(let ((d (cmp-eval dimensions)))
(when (or (integerp d) (and (listp d) (= (length d) 1) (setf d (first d))))
(setf function 'si::make-vector
dimensions `',d)))
(setf form
`(,function ,element-type ,dimensions ,adjustable ,fill-pointer
,displaced-to ,displaced-index-offset)))))
form)
;;;
;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND
;;;
(defun expand-vector-push (whole env)
(declare (si::c-local))
(let* ((extend (eq (first whole) 'vector-push-extend))
(args (rest whole)))
(unless (or ;; Avoid infinite recursion
(eq (first args) '.val)
(safe-compile)
(>= (cmp-env-optimization 'space env) 2))
(setf whole
`(let* ((.val ,(car args))
(.vec ,(second args))
(.i (fill-pointer .vec))
(.dim (array-total-size .vec)))
(declare (fixnum .i .dim)
(:read-only .vec .val .i .dim))
(cond ((< .i .dim)
(sys::fill-pointer-set .vec (the fixnum (+ 1 .i)))
(sys::aset .val .vec .i)
.i)
(t ,(when extend
`(vector-push-extend .val .vec ,@(cddr args)))))))))
whole)
(define-compiler-macro vector-push (&whole whole &rest args &environment env)
(expand-vector-push whole env))
(define-compiler-macro vector-push-extend (&whole whole &rest args &environment env)
(expand-vector-push whole env))

9
src/cmp/cmpcall.lsp
View file

@ -154,7 +154,8 @@
(cond
;; Check whether it is a global function that we cannot call directly.
((and (or (null loc) (fun-global loc)) (not (inline-possible fname)))
(if (and *compile-to-linking-call* (<= *debug* 1))
(if (and *compile-to-linking-call*
(<= (cmp-env-optimization 'debug) 1))
(call-linking-loc fname narg args)
(call-unknown-global-loc fname nil narg args)))
@ -165,7 +166,7 @@
;; Call to a function defined in the same file. Direct calls are
;; only emitted for low or neutral values of DEBUG is >= 2.
((and (<= *debug* 1)
((and (<= (cmp-env-optimization 'debug) 1)
(or (fun-p loc)
(and (null loc)
(setf loc (find fname *global-funs* :test #'same-fname-p
@ -179,7 +180,7 @@
;; Call to a function whose C language function name is known,
;; either because it has been proclaimed so, or because it belongs
;; to the runtime.
((and (<= *debug* 1)
((and (<= (cmp-env-optimization 'debug) 1)
(setf fd (get-sysprop fname 'Lfun))
(multiple-value-setq (minarg maxarg) (get-proclaimed-narg fname)))
(call-exported-function-loc fname narg args fd minarg maxarg
@ -190,7 +191,7 @@
(call-exported-function-loc fname narg args fd minarg maxarg t))
;; Linking calls can only be made to symbols
((and *compile-to-linking-call* (<= *debug* 1))
((and *compile-to-linking-call* (<= (cmp-env-optimization 'debug) 1))
(call-linking-loc fname narg args))
(t (call-unknown-global-loc fname loc narg args))))

69
src/cmp/cmpenv.lsp
View file

@ -363,24 +363,28 @@
((eq j what)
(return 3)))))))
(defun c1add-declarations (decls &aux (dl nil))
(dolist (decl decls dl)
(defun c1add-declarations (decls &aux (dl nil) (optimizations))
(dolist (decl decls)
(case (car decl)
(OPTIMIZE
(push decl dl)
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(unless optimizations
(setq optimizations (cmp-env-all-optimizations)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (second x)))
(not (<= 0 (second x) 3)))
(cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(DEBUG (setq *debug* (second x)))
(SAFETY (setq *safety* (second x)))
(SPACE (setq *space* (second x)))
((SPEED COMPILATION-SPEED))
(t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(let ((value (second x)))
(case (car x)
(DEBUG (setf (first optimizations) value))
(SAFETY (setf (second optimizations) value))
(SPACE (setf (third optimizations) value))
(SPEED (setf (fourth optimizations) value))
(COMPILATION-SPEED)
(t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))))
(FTYPE
(let (ftype)
(cond ((and (consp (cdr decl))
@ -410,7 +414,13 @@
(:READ-ONLY)
(otherwise
(unless (member (car decl) si:*alien-declarations*)
(cmpwarn "The declaration specifier ~s is unknown." (car decl)))))))
(cmpwarn "The declaration specifier ~s is unknown." (car decl))))))
(when optimizations
(setf *cmp-env*
(cons (cons `(:declare optimize ,@optimizations)
(car *cmp-env*))
(cdr *cmp-env*))))
dl)
(defun c1decl-body (decls body)
(if (null decls)
@ -418,10 +428,7 @@
(let* ((*function-declarations* *function-declarations*)
(si:*alien-declarations* si:*alien-declarations*)
(*notinline* *notinline*)
(*safety* *safety*)
(*space* *space*)
(*speed* *speed*)
(*debug* *debug*)
(*cmp-env* *cmp-env*)
(dl (c1add-declarations decls)))
(setq body (c1progn body))
(make-c1form 'DECL-BODY body dl body))))
@ -429,10 +436,7 @@
(put-sysprop 'decl-body 'c2 'c2decl-body)
(defun c2decl-body (decls body)
(let ((*safety* *safety*)
(*space* *space*)
(*speed* *speed*)
(*debug* *debug*)
(let ((*cmp-env* *cmp-env*)
(*notinline* *notinline*))
(c1add-declarations decls)
(c2expr body)))
@ -575,23 +579,36 @@
when (and (consp i) (var-p (fourth i)))
collect (fourth i)))
(defmacro cmp-env-optimization (property &optional env)
(case (eval property)
(speed '*speed*)
(safety '*safety*)
(space '*space*)
(debug '*debug*)))
(defun cmp-env-all-optimizations (&optional (env *cmp-env*))
(loop for i in (car env)
when (and (consp i)
(eq (first i) :declare)
(eq (second i) 'optimize))
do (return (cddr i))
finally (return (list *debug* *safety* *space* *speed*))))
(defun policy-inline-slot-access-p (&optional env)
(defun cmp-env-optimization (property &optional (env *cmp-env*))
(let ((x (cmp-env-all-optimizations env)))
(case property
(debug (first x))
(safety (second x))
(space (third x))
(speed (fourth x)))))
(defun policy-inline-slot-access-p (&optional (env *cmp-env*))
"Do we inline access to structures and sealed classes?"
(or (< (cmp-env-optimization 'safety env) 2)
(<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
(defun policy-check-all-arguments-p (&optional env)
(defun policy-check-all-arguments-p (&optional (env *cmp-env*))
"Do we assume that arguments are the right type?"
(> (cmp-env-optimization 'safety env) 1))
(defun policy-automatic-check-type-p (&optional env)
(defun policy-automatic-check-type-p (&optional (env *cmp-env*))
"Do we generate CHECK-TYPE forms for function arguments with type declarations?"
(and *automatic-check-type-in-lambda*
(>= (cmp-env-optimization 'safety env) 1)))
(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*))
"Do we assume that type and class definitions will not change?"
(<= (cmp-env-optimization 'safety env) 1))

26
src/cmp/cmpfun.lsp
View file

@ -291,30 +291,6 @@
(subtypep (result-type (second args)) 'FIXNUM)
(c1expr `(the fixnum (ldb1 ,size ,pos ,(second args))))))
;----------------------------------------------------------------------
(defun co1vector-push (args) (co1vector-push1 nil args))
(defun co1vector-push-extend (args) (co1vector-push1 t args))
(defun co1vector-push1 (extend args)
(unless (or (safe-compile)
(> *space* 3)
(null (cdr args)))
(let ((*space* 10))
(c1expr
`(let* ((.val ,(car args))
(.vec ,(second args))
(.i (fill-pointer .vec))
(.dim (array-total-size .vec)))
(declare (fixnum .i .dim)
(type ,(result-type (second args)) .vec)
(type ,(result-type (car args)) .val))
(cond ((< .i .dim)
(the fixnum (sys::fill-pointer-set .vec (the fixnum (+ 1 .i))))
(sys::aset .val .vec .i)
.i)
(t ,(when extend
`(vector-push-extend .val .vec ,@(cddr args))))))))))
;;; ----------------------------------------------------------------------
(put-sysprop 'princ 'C1 'c1princ)
@ -339,5 +315,3 @@
(put-sysprop 'coerce 'C1CONDITIONAL 'co1coerce)
(put-sysprop 'cons 'C1CONDITIONAL 'co1cons)
(put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb)
(put-sysprop 'vector-push 'C1CONDITIONAL 'co1vector-push)
(put-sysprop 'vector-push-extend 'C1CONDITIONAL 'co1vector-push-extend)

3
src/cmp/cmplam.lsp
View file

@ -448,6 +448,9 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
(wt (if allow-other-keys ",TRUE);" ",FALSE);"))))
(when rest (bind rest-loc rest)))
(when varargs
(wt-nl (if simple-varargs "va_end(args);" "cl_va_end(args);")))
;;; Bind keywords.
(do ((kwd keywords (cddddr kwd))
(all-kwd nil)

6
src/cmp/cmpmac.lsp
View file

@ -60,13 +60,13 @@
`(wt #\Newline ,@forms))
(defmacro safe-compile ()
`(>= *safety* 2))
`(>= (cmp-env-optimization 'safety) 2))
(defmacro compiler-check-args ()
`(>= *safety* 1))
`(>= (cmp-env-optimization 'safety) 1))
(defmacro compiler-push-events ()
`(>= *safety* 3))
`(>= (cmp-env-optimization 'safety) 3))
;; ----------------------------------------------------------------------
;; C1-FORMS

2
src/cmp/cmpmain.lsp
View file

@ -839,7 +839,7 @@ Cannot compile ~a."
(safe-system
(format nil
*cc-format*
*cc* *cc-flags* (>= *speed* 2) *cc-optimize*
*cc* *cc-flags* (>= (cmp-env-optimization 'speed) 2) *cc-optimize*
(fix-for-mingw (ecl-include-directory))
(si::coerce-to-filename c-pathname)
(si::coerce-to-filename o-pathname))

5
src/cmp/cmptop.lsp
View file

@ -479,10 +479,7 @@
(wt-label *exit*)))
(defun t2decl-body (decls body)
(let ((*safety* *safety*)
(*space* *space*)
(*speed* *speed*)
(*debug* *debug*)
(let ((*cmp-env* *cmp-env*)
(*notinline* *notinline*))
(c1add-declarations decls)
(t2expr body)))

5
src/cmp/cmptype.lsp
View file

@ -117,6 +117,9 @@
(values nil nil))
(error (c) (values nil nil))))
(defun known-type-p (type)
(subtypep type 'T))
(defun type-and (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
@ -399,7 +402,7 @@
:safe "In the argument ~d of a call to ~a" i fname)
;; In safe mode, we cannot assume that the type of the
;; argument is going to be the right one.
(unless (zerop *safety*)
(unless (zerop (cmp-env-optimization 'safety))
(setf (c1form-type form) old-type))))))
return-type))

1
src/cmp/load.lsp.in
View file

@ -35,6 +35,7 @@
"src:cmp;cmpopt.lsp"
"src:cmp;cmpclos.lsp"
"src:cmp;cmpstructures.lsp"
"src:cmp;cmparray.lsp"
"src:cmp;cmpmain.lsp"))
(let ((si::*keep-documentation* nil))

9027
src/configure vendored
View file

File diff suppressed because it is too large Load diff

3
src/configure.in
View file

@ -314,6 +314,9 @@ fi
dnl ----------------------------------------------------------------------
dnl Boehm-Weiser garbage collector
if test ${enable_boehm} = "no" ; then
AC_MSG_ERROR([Boehm GC library is currently needed to build ECL]);
fi
if test ${enable_boehm} = "no" ; then
EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}"
enable_smallcons="no"

6
src/h/external.h
View file

@ -204,7 +204,6 @@ extern ECL_API cl_object cl_alloc_object(cl_type t);
extern ECL_API cl_object cl_alloc_instance(cl_index slots);
extern ECL_API cl_object ecl_cons(cl_object a, cl_object d);
extern ECL_API cl_object ecl_list1(cl_object a);
extern ECL_API void cl_dealloc(void *p, cl_index s);
#ifdef GBC_BOEHM
extern ECL_API cl_object si_gc(cl_object area);
extern ECL_API cl_object si_gc_dump(void);
@ -213,7 +212,7 @@ extern ECL_API cl_object si_gc_stats(cl_object enable);
#define cl_alloc_atomic GC_malloc_atomic_ignore_off_page
#define cl_alloc_align(s,d) GC_malloc_ignore_off_page(s)
#define cl_alloc_atomic_align(s,d) GC_malloc_atomic_ignore_off_page(s)
#define cl_dealloc(p,s)
#define cl_dealloc(p) GC_free(p)
#define ecl_register_static_root(x) ecl_register_root(x)
#else
extern ECL_API cl_object si_allocate _ARGS((cl_narg narg, cl_object type, cl_object qty, ...));
@ -230,6 +229,7 @@ extern ECL_API void *cl_alloc(cl_index n);
extern ECL_API void *cl_alloc_align(cl_index size, cl_index align);
extern ECL_API void *ecl_alloc_uncollectable(size_t size);
extern ECL_API void ecl_free_uncollectable(void *);
extern ECL_API void cl_dealloc(void *p);
#define cl_alloc_atomic(x) cl_alloc(x)
#define cl_alloc_atomic_align(x,s) cl_alloc_align(x,s)
#define ecl_register_static_root(x) ecl_register_root(x);
@ -280,7 +280,7 @@ extern ECL_API cl_object si_fill_pointer_set(cl_object a, cl_object fp);
extern ECL_API cl_object si_replace_array(cl_object old_obj, cl_object new_obj);
extern ECL_API cl_object cl_aref _ARGS((cl_narg narg, cl_object x, ...));
extern ECL_API cl_object si_aset _ARGS((cl_narg narg, cl_object v, cl_object x, ...));
extern ECL_API cl_object si_make_pure_array _ARGS((cl_narg narg, cl_object etype, cl_object adj, cl_object displ, cl_object disploff, ...));
extern ECL_API cl_object si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff);
extern ECL_API cl_index ecl_to_index(cl_object n);
extern ECL_API cl_object ecl_aref(cl_object x, cl_index index);

17
src/lsp/arraylib.lsp
View file

@ -43,22 +43,9 @@ in raw-major indexing is actually the reference to the (I + DISPLACED-INDEX-
OFFSET)th element of the given array.If the STATIC argument is supplied
with a non-nil value, then the body of the array is allocated as a
contiguous block."
(setq element-type (upgraded-array-element-type element-type))
(let (x)
(let ((x (sys:make-pure-array element-type dimensions adjustable
fill-pointer displaced-to displaced-index-offset)))
(declare (array x))
(cond ((or (integerp dimensions)
(when (= (length dimensions) 1)
(setq dimensions (first dimensions))))
(setf x (sys:make-vector element-type dimensions
adjustable fill-pointer
displaced-to displaced-index-offset)))
(fill-pointer
(error ":FILL-POINTER may not be specified for an array of rank ~D"
(length dimensions)))
(t
(setf x (apply #'sys:make-pure-array element-type adjustable
displaced-to displaced-index-offset dimensions))))
(when initial-element-supplied-p
(dotimes (i (array-total-size x))
(declare (fixnum i))

2
src/lsp/config.lsp.in
View file

@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs."
(defun lisp-implementation-version ()
"Args:()
Returns the version of your ECL as a string."
"@PACKAGE_VERSION@ (CVS 2008-05-14 13:43)")
"@PACKAGE_VERSION@ (CVS 2008-05-18 22:07)")
(defun machine-type ()
"Args: ()