在Raspberry Pi上安装Clozure Common Lisp

  • 0

在Raspberry Pi上安装Clozure Common Lisp

Category:安装设置 Tags : 

原文地址:http://lispm.de/ccl
此文章部分内容已过时,仅供参考,有时间了我再修改更新

3. 2012年10月,Rainer Joswig,joswig @ llisp.de,2016年3月更新

Raspberry Pi和ODROID-U3

在这里,我将描述如何获得Clozure Common Lisp,简短CCL,在Raspberry Pi,Odroid和类似计算机上运行。我还将介绍如何将Quicklisp和SLIME / Emacs与CCL一起使用。结果将是Common Lisp的免费开源开发环境 – 在一台小巧且价格合理的计算机上。

更新:这个网站现在运行在一个超级快速的ODROID-XU上,它几乎和Raspberry Pi一样小 – 虽然相当昂贵且功能更强大。Hardkernel正在销售ODROID-U3和ODROID-C1–两者都比XU便宜一些,但仍然非常快。

Clozure Associates – Clozure Common Lisp由Clozure Associates开发和支持,Clozure Associates也提供Common Lisp编程方面的咨询服务。

硬件选项

你需要一台运行Raspbian操作系统的Raspberry Pi计算机(基于Debian的GNU / Linux版本)。B型配有512 MB RAM。

请注意,此处的信息也适用于运行GNU / Linux版本的类似基于ARM的计算机。我已经能够在ODROID-X2和ODROID-XU上安装Clozure Common Lisp – 这两款基于ARM的四核小型计算机。需要重新编译Lisp内核(见下文)。有些ODROID主板比Raspberry Pi要贵一些,但是它们在2GB内存的快速处理器上执行Lisp的速度要快得多。新的微型ODROID-C1具有1 GB RAM,千兆以太网和运行速度为1.5 Ghz的四核ARM处理器 – 仅44欧元。

另请注意,Rasberry Pi使用的是ARMv6架构。ODROID使用ARMv7架构。

Raspberry Pi 3 – 一种小型且价格合理的基于ARM的计算机,仅使用非常少的电力。

ODROID U2,U3,X2,XU,C1,C2,XU3和XU4 – 微型且非常强大的计算机,具有四核/八核ARM处理器和高达2 GB的RAM。运行Clozure Common Lisp比原始的Raspberry Pi快得多。

96板 – ARM板规范

LeMaker Cello – 采用96Board EE规格的ARM 64位服务器主板,采用AMD的A1100四核CPU

NVIDIA Jetson TX1 – 来自NVIDIA的开发人员套件

海洋 – 便携式服务器

Pine64 – 非常便宜(15美元)的64位电路板

GeekBox – 采用64位八核处理器的开源电视盒

Aquaris M10 Ubuntu Edition – 在四核64位ARM处理器上运行Ubuntu / GNU / Linux的平板电脑/ PC

基于云的根服务器选项

2015年,出现了一些基于ODROID XU4或其他基于ARM的硬件提供基于云的根服务器的公司。

位置
Norplex微微 Odroid XU4 德国
航道C1 C1 Quadcore 法国
miniNodes HiKey 64位ARM 美国亚利桑那州凤凰城
基准
Raspberry Pi CCL ODROID-X2 CCL MacBook Air i7 CCL
KM测试套件 91.20s 10.10s 3.03s
微型Talespin故事4 0.28s 0.023s 0.01S
安装Clozure Common Lisp(CCL)

我假设您愿意在命令行上使用Linux,使用GNU Emacs,基于Emacs的Common Lisp的SLIME开发环境,当然还有Clozure Common Lisp。

CCL提供基于本机代码编译器的Common Lisp实现,支持线程和CLOS(Common Lisp Object System)的高效实现。CCL还有一个非常快的垃圾收集器。CCL由Clozure Associates提供支持。它起源于80年代中期Macintosh的小型商业Common Lisp实现:Macintosh Common Lisp。那时Macintosh只有几兆字节的RAM。后来CCL已经分叉,移植到各种平台并开源。这就是我们将要使用的。

对于Raspberry Pi(和类似计算机)上的Lisp编程,CCL是理想的选择。它相对紧凑,具有快速的本机代码编译器,并提供完整的Common Lisp语言的扩展实现。CCL还可在其他各种平台上运行:Mac,Windows PC,…对于Mac,您可以从Apple的App Store下载,以便于安装。CCL最引人注目的用途肯定是谷歌的航空票价搜索引擎 – 这是一款由谷歌收购的ITA软件以前编写的软件。

CCL用Common Lisp编写,其运行时系统有点C。目前,Raspberry Pi没有真正简单的CCL安装。通常完全重建CCL很有用 – 但这并不困难。

我们需要一些CCL工具:Subversion,GNU Emacs gcc,ld,m4或gm4,as,make,curl。如果您还没有安装,可以通过’apt-get’获取。

http://ccl.clozure.com – 是CCL的主页。

http://ccl.clozure.com/manual/ – 是CCL的手册。

Common Lisp HyperSpec – 是Common Lisp的语言参考

对于CCL的安装,我们需要一个运行Raspbian操作系统的Raspberry Pi上的目录。移动到要安装CCL的目录。然后使用Subversion客户端获取最新的源代码。

svn co http://svn.clozure.com/publicsvn/openmcl/trunk/linuxarm/ccl

上面创建了一个名为’ccl’的目录,其中包含所有Clozure CL以及所有来源。CCL的可能平台有:darwinx86,freebsdx86,linuxarm,linuxppc,linuxx86,solarisx86,windows)。由于我们的ARM计算机在Linux下运行,我们这里使用linuxarm作为平台。

-rwxr-xr-x  1 pi pi   532707 Oct  3 11:35 armcl
-rw-r--r--  1 pi pi 21381136 Oct  3 11:34 armcl.image
drwxr-xr-x  6 pi pi     4096 Oct  3 11:36 arm-headers
drwxr-xr-x  6 pi pi     4096 Oct  3 11:35 compiler
drwxr-xr-x  8 pi pi     4096 Oct  3 11:35 contrib
drwxr-xr-x  4 pi pi     4096 Oct  3 11:35 doc
drwxr-xr-x  9 pi pi     4096 Oct  3 11:35 examples
drwxr-xr-x  6 pi pi     4096 Oct  3 11:35 level-0
drwxr-xr-x  3 pi pi     4096 Oct  3 11:35 level-1
drwxr-xr-x  3 pi pi     4096 Oct  3 11:36 lib
drwxr-xr-x  3 pi pi     4096 Oct  3 11:36 library
drwxr-xr-x 19 pi pi     4096 Oct  3 11:36 lisp-kernel
drwxr-xr-x  4 pi pi     4096 Oct  3 11:36 objc-bridge
drwxr-xr-x  3 pi pi     4096 Oct  3 11:36 scripts
drwxr-xr-x  3 pi pi     4096 Oct  3 11:36 tools
drwxr-xr-x  3 pi pi     4096 Oct  3 11:36 xdump

‘armcl’是CCL运行时的可执行文件。它还使用’armcl.image’,其中包含所有CCL的Lisp的转储。它包括例如本机代码编译器。正如您所看到的,CCL图像略大于20MB – 但它的加载速度非常快。第一次启动CCL应该只需要两秒钟,之后它将不到一秒钟。让我们从’ccl’目录开始Clozure CL。

$ ./armcl
Welcome to Clozure Common Lisp Version 1.9-dev-r15424M-trunk  (LinuxARM32)!
? (quit)
从Subversion存储库更新并重建CCL

有时会对Clozure CL和新功能进行新的修复。如果要获取最新的源,则需要更新subversion存储库中的源。

移至CCL目录并更新源。

$ svn update

您应该看到subversion客户端连接到Clozure CL存储库并查找代码更新。

现在我们对CCL进行全面重建,包括所有Lisp源。这将需要一些时间,具体取决于您的计算机的速度。确保您仍然在ccl目录中,然后让我们重建所有内容。

$ ./armcl
Welcome to Clozure Common Lisp Version 1.9-dev-r15424M-trunk  (LinuxARM32)!
? (ccl:rebuild-ccl :full t)

完成后,您可以通过调用(退出)退出CCL。您可能想要启动新创建的armcl并再次执行重建步骤(不确定它是否真的有用,我已经读过,需要两次重建才能解决所有依赖关系)。

就是这样 – 现在你的计算机上有一个新的Clozure Common Lisp。

在ARM计算机上运行CCL的可能问题

如果上面不起作用(例如,新检出的CCL确实在我的ODROID上使用Ubuntu工作),只需重新制作内核 – 就像下一步一样。

浮点数实现和CPU / OS支持可能导致问题。

例如,我们可能希望确保CCL在可能的情况下使用硬浮点数。这样CCL将使用Raspberry Pi的ARM处理器的浮点引擎。(在其他一些机器上它可能不可用,一个使用软浮动。)编辑文件float_abi.mk,将文件中的变量设置为’hard’(请注意,在较新版本的CCL中,这不是必需的,但请检查文件以确定)并重建CCL内核。

$ cd lisp-kernel/linuxarm/
$ emacs float_abi.mk
$ make clean
$ make

现在我们对CCL进行全面重建,包括所有Lisp源,如上所述。

$ ./armcl
Welcome to Clozure Common Lisp Version 1.9-dev-r15424M-trunk  (LinuxARM32)!
? (ccl:rebuild-ccl :full t)

CCL无法识别CPU会导致另一个问题。然后我们在启动时看到此错误消息:

CPU doesn't support required features

马克布朗发出以下信息:

The problem is that Clozure CL parses this information but expects the
'processor' line to start with an upper case 'P' (i.e. 'Processor')
and doesn't recognise the 'processor' line (starting with a lower case
'p') returned by the Raspberry Pi.

The solution is simple: edit the function check_arm_cpu() in
pmcl_kernel.c to use strncasecmp instead of strcasecmp when parsing
the CPU information. I attach a modified version of check_arm_cpu()
that does this (and also fixes a potential bug in that the return
values of calls to malloc() were not being checked).

pmcl-kernel.c – Mark Brown对pmcl-kernel.c的修复

/*
   Copyright (C) 2009 Clozure Associates
   Copyright (C) 1994-2001 Digitool, Inc
   This file is part of Clozure CL.  

   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
   License , known as the LLGPL and distributed with Clozure CL as the
   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
   which is distributed with Clozure CL as the file "LGPL".  Where these
   conflict, the preamble takes precedence.  

   Clozure CL is referenced in the preamble as the "LIBRARY."

   The LLGPL is also available online at
   http://opensource.franz.com/preamble.html
*/

#include "lisp.h"
#include "lisp_globals.h"
#include "gc.h"
#include "area.h"
#include <stdlib.h>
#include <string.h>
#include "lisp-exceptions.h"
#include <stdio.h>
#include <stdlib.h>
#ifndef WINDOWS
#include <sys/mman.h>
#endif
#include <fcntl.h>
#include <signal.h>
#include <errno.h>
#ifndef WINDOWS
#include <sys/utsname.h>
#include <unistd.h>
#endif

#ifdef LINUX
#ifndef ANDROID
#include <mcheck.h>
#endif
#include <dirent.h>
#include <dlfcn.h>
#include <sys/time.h>
#include <sys/resource.h>
#ifdef ANDROID
#ifdef ARM
#define ANDROID_ARM_LINKER 1
#endif
#include <linker.h>
#else
#include <link.h>
#endif
#ifndef ANDROID
#include <elf.h>
#endif

/* 
   The version of <asm/cputable.h> provided by some distributions will
   claim that <asm-ppc64/cputable.h> doesn't exist.  It may be present
   in the Linux kernel source tree even if it's not copied to
   /usr/include/asm-ppc64.  Hopefully, this will be straightened out
   soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined
   in a less volatile place.)  Until that's straightened out, it may
   be necessary to install a copy of the kernel header in the right
   place and/or persuade <asm/cputable> to lighten up a bit.
*/

#ifdef PPC
#ifndef PPC64
#include <asm/cputable.h>
#endif
#ifndef PPC_FEATURE_HAS_ALTIVEC
#define PPC_FEATURE_HAS_ALTIVEC 0x10000000
#endif
#endif
#endif


#ifdef DARWIN
#include <sys/types.h>
#include <sys/time.h>
#include <sys/mman.h>
#include <sys/resource.h>
#include <sys/sysctl.h>
#undef undefined
#include <mach-o/dyld.h>
#include <dlfcn.h>
#include <libgen.h>
#endif

#if defined(FREEBSD) || defined(SOLARIS)
#include <sys/time.h>
#include <sys/resource.h>
#include <dlfcn.h>
#include <elf.h> 
#include <link.h>
#endif

#include <ctype.h>
#ifndef WINDOWS
#include <sys/select.h>
#endif
#include "threads.h"

#if !(defined(DARWIN) && defined(ARM))
#include <fenv.h>
#endif
#include <sys/stat.h>

#ifndef MAP_NORESERVE
#define MAP_NORESERVE (0)
#endif

#ifdef WINDOWS
#include <windows.h>
#include <stdio.h>
void
wperror(char* message)
{
  char* buffer;
  DWORD last_error = GetLastError();
  
  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
		FORMAT_MESSAGE_FROM_SYSTEM|
		FORMAT_MESSAGE_IGNORE_INSERTS,
		NULL,
		last_error,
		MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
		(LPTSTR)&buffer,
		0, NULL);
  fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
  LocalFree(buffer);
}
#endif

LispObj lisp_nil = (LispObj) 0;
bitvector global_mark_ref_bits = NULL, dynamic_mark_ref_bits = NULL, relocatable_mark_ref_bits = NULL;


/* These are all "persistent" : they're initialized when
   subprims are first loaded and should never change. */
extern LispObj ret1valn;
extern LispObj nvalret;
extern LispObj popj;

LispObj text_start = 0;

/* A pointer to some of the kernel's own data; also persistent. */

extern LispObj import_ptrs_base;




void
make_dynamic_heap_executable(void *p, void *q)
{
  void * cache_start = (void *) p;
  natural ncacheflush = (natural) q - (natural) p;

  xMakeDataExecutable(cache_start, ncacheflush);  
}
      
size_t
ensure_stack_limit(size_t stack_size)
{
#ifdef WINDOWS
  extern void os_get_current_thread_stack_bounds(void **, natural*);
  natural totalsize;
  void *ignored;
  
  os_get_current_thread_stack_bounds(&ignored, &totalsize);

  return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT);

#else
  struct rlimit limits;
  rlim_t cur_stack_limit, max_stack_limit;
 
  stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT);
  getrlimit(RLIMIT_STACK, &limits);
  cur_stack_limit = limits.rlim_cur;
  max_stack_limit = limits.rlim_max;
  if (stack_size > max_stack_limit) {
    stack_size = max_stack_limit;
  }
  if (cur_stack_limit < stack_size) {
    limits.rlim_cur = stack_size;
    errno = 0;
    if (setrlimit(RLIMIT_STACK, &limits)) {
      int e = errno;
      fprintf(dbgout, "errno = %d\n", e);
      Fatal(": Stack resource limit too small", "");
    }
  }
#endif
  return stack_size;
}


/* This should write-protect the bottom of the stack.
   Doing so reliably involves ensuring that everything's unprotected on exit.
*/

BytePtr
allocate_lisp_stack(natural useable,
                    unsigned softsize,
                    unsigned hardsize,
                    lisp_protection_kind softkind,
                    lisp_protection_kind hardkind,
                    Ptr *h_p,
                    BytePtr *base_p,
                    protected_area_ptr *softp,
                    protected_area_ptr *hardp)
{
  void *allocate_stack(natural);
  void free_stack(void *);
  natural size = useable+softsize+hardsize;
  natural overhead;
  BytePtr base, softlimit, hardlimit;
  Ptr h = allocate_stack(size+4095);
  protected_area_ptr hprotp = NULL, sprotp;

  if (h == NULL) {
    return NULL;
  }
  if (h_p) *h_p = h;
  base = (BytePtr) align_to_power_of_2( h, log2_page_size);
  hardlimit = (BytePtr) (base+hardsize);
  softlimit = hardlimit+softsize;

  overhead = (base - (BytePtr) h);
  if (hardsize) {
    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true);
    if (hprotp == NULL) {
      if (base_p) *base_p = NULL;
      if (h_p) *h_p = NULL;
      free(h);
      return NULL;
    }
    if (hardp) *hardp = hprotp;
  }
  if (softsize) {
    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
    if (sprotp == NULL) {
      if (base_p) *base_p = NULL;
      if (h_p) *h_p = NULL;
      if (hardp) *hardp = NULL;
      if (hprotp) delete_protected_area(hprotp);
      free_stack(h);
      return NULL;
    }
    if (softp) *softp = sprotp;
  }
  if (base_p) *base_p = base;
  return (BytePtr) ((natural)(base+size));
}

/*
  This should only called by something that owns the area_lock, or
  by the initial thread before other threads exist.
*/
area *
allocate_lisp_stack_area(area_code stack_type,
                         natural usable,
                         unsigned softsize, 
                         unsigned hardsize, 
                         lisp_protection_kind softkind, 
                         lisp_protection_kind hardkind)

{
  BytePtr base, bottom;
  Ptr h;
  area *a = NULL;
  protected_area_ptr soft_area=NULL, hard_area=NULL;

  bottom = allocate_lisp_stack(usable, 
                               softsize, 
                               hardsize, 
                               softkind, 
                               hardkind, 
                               &h, 
                               &base,
                               &soft_area, 
                               &hard_area);

  if (bottom) {
    a = new_area(base, bottom, stack_type);
    a->hardlimit = base+hardsize;
    a->softlimit = base+hardsize+softsize;
    a->h = h;
    a->softprot = soft_area;
    a->hardprot = hard_area;
    add_area_holding_area_lock(a);
  }
  return a;
}

/*
  Also assumes ownership of the area_lock 
*/
area*
register_cstack_holding_area_lock(BytePtr bottom, natural size)
{
  BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095);
  area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK);
  if (size > (CSTACK_HARDPROT + CSTACK_SOFTPROT)) {
    a->hardlimit = lowlimit+CSTACK_HARDPROT;
    a->softlimit = a->hardlimit+CSTACK_SOFTPROT;
  } else {
    a->softlimit = a->hardlimit = lowlimit;
  }
#ifdef USE_SIGALTSTACK
  setup_sigaltstack(a);
#endif
#ifdef PROTECT_CSTACK
  if (a->softlimit != a->hardlimit) {
    a->softprot=new_protected_area(a->hardlimit,a->softlimit,kSPsoftguard,CSTACK_SOFTPROT,true);
    a->hardprot=new_protected_area(lowlimit,a->hardlimit,kSPhardguard,CSTACK_HARDPROT,true);
  }
#endif
  add_area_holding_area_lock(a);
  return a;
}
  

area*
allocate_vstack_holding_area_lock(natural usable)
{
  return allocate_lisp_stack_area(AREA_VSTACK, 
				  usable > MIN_VSTACK_SIZE ?
				  usable : MIN_VSTACK_SIZE,
                                  VSTACK_SOFTPROT,
                                  VSTACK_HARDPROT,
                                  kVSPsoftguard,
                                  kVSPhardguard);
}

area *
allocate_tstack_holding_area_lock(natural usable)
{
  return allocate_lisp_stack_area(AREA_TSTACK, 
                                  usable > MIN_TSTACK_SIZE ?
				  usable : MIN_TSTACK_SIZE,
                                  TSTACK_SOFTPROT,
                                  TSTACK_HARDPROT,
                                  kTSPsoftguard,
                                  kTSPhardguard);
}


/* It's hard to believe that max & min don't exist already */
unsigned unsigned_min(unsigned x, unsigned y)
{
  if (x <= y) {
    return x;
  } else {
    return y;
  }
}

unsigned unsigned_max(unsigned x, unsigned y)
{
  if (x >= y) {
    return x;
  } else {
    return y;
  }
}

natural
reserved_area_size = MAXIMUM_MAPPABLE_MEMORY;

BytePtr reserved_region_end = NULL;

area 
  *nilreg_area=NULL,
  *tenured_area=NULL, 
  *g2_area=NULL, 
  *g1_area=NULL,
  *managed_static_area=NULL,
  *static_cons_area=NULL,
  *readonly_area=NULL;

area *all_areas=NULL;
int cache_block_size=32;


#if WORD_SIZE == 64
#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20)
#define G2_AREA_THRESHOLD (8<<20)
#define G1_AREA_THRESHOLD (4<<20)
#define G0_AREA_THRESHOLD (2<<20)
#else
#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20)
#define G2_AREA_THRESHOLD (4<<20)
#define G1_AREA_THRESHOLD (2<<20)
#define G0_AREA_THRESHOLD (1<<20)
#endif

#define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2)

#if (WORD_SIZE == 32)
#define DEFAULT_INITIAL_STACK_SIZE (1<<20)
#else
#define DEFAULT_INITIAL_STACK_SIZE (2<<20)
#endif

natural
lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD;

natural
lisp_heap_notify_threshold = 0;

natural 
initial_stack_size = DEFAULT_INITIAL_STACK_SIZE;

natural
thread_stack_size = 0;


/*
  'start' should be on a segment boundary; 'len' should be
  an integral number of segments.  remap the entire range.
*/

void 
uncommit_pages(void *start, size_t len)
{
  UnCommitMemory(start, len);
}

#define TOUCH_PAGES_ON_COMMIT 0

Boolean
touch_all_pages(void *start, size_t len)
{
#if TOUCH_PAGES_ON_COMMIT
  extern Boolean touch_page(void *);
  char *p = (char *)start;

  while (len) {
    if (!touch_page(p)) {
      return false;
    }
    len -= page_size;
    p += page_size;
  }
#endif
  return true;
}

Boolean
commit_pages(void *start, size_t len)
{
  if (len != 0) {
    if (!CommitMemory(start, len)) {
      return false;
    }
    if (!touch_all_pages(start, len)) {
      return false;
    }
  }
  return true;
}

area *
find_readonly_area()
{
  area *a;

  for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) {
    if (a->code == AREA_READONLY) {
      return a;
    }
  }
  return NULL;
}

area *
extend_readonly_area(natural more)
{
  area *a;
  unsigned mask;
  BytePtr new_start, new_end;

  if ((a = find_readonly_area()) != NULL) {
    if ((a->active + more) > a->high) {
      return NULL;
    }
    mask = ((natural)a->active) & (page_size-1);
    if (mask) {
      UnProtectMemory(a->active-mask, page_size);
    }
    new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size));
    new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size));
    if (!CommitMemory(new_start, new_end-new_start)) {
      return NULL;
    }
    return a;
  }
  return NULL;
}

LispObj image_base=0;
BytePtr pure_space_start, pure_space_active, pure_space_limit;
BytePtr static_space_start, static_space_active, static_space_limit;

void
raise_limit()
{
#ifdef RLIMIT_AS
  struct rlimit r;
  if (getrlimit(RLIMIT_AS, &r) == 0) {
    r.rlim_cur = r.rlim_max;
    setrlimit(RLIMIT_AS, &r);
    /* Could limit heaplimit to rlim_max here if smaller? */
  }
#endif
} 


area *
create_reserved_area(natural totalsize)
{
  Ptr h;
  natural base;
  BytePtr 
    end, 
    lastbyte, 
    start, 
    want = (BytePtr)IMAGE_BASE_ADDRESS;
  area *reserved;
  Boolean fatal = false;

  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
    
  if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) {
    totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE;
    fatal = true;
  }

  start = ReserveMemoryForHeap(want, totalsize);

  if (start == NULL) {
    if (fatal) {
#ifdef WINDOWS
      wperror("minimal initial mmap");
#else
      perror("minimal initial mmap");
#endif
      exit(1);
    }
    return NULL;
  }

  h = (Ptr) start;
  base = (natural) start;
  image_base = base;
  lastbyte = (BytePtr) (start+totalsize);
  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
  static_space_limit = static_space_start + STATIC_RESERVE;
  pure_space_start = pure_space_active = start;
  pure_space_limit = start + PURESPACE_SIZE;
  start += PURESPACE_RESERVE;

  /*
    Allocate mark bits here.  They need to be 1/64 the size of the
     maximum useable area of the heap (+ 3 words for the EGC.)
  */
  end = lastbyte;
  reserved_region_end = lastbyte;
  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095));

  global_mark_ref_bits = (bitvector)end;
  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095));
  global_reloctab = (LispObj *) end;
  reserved = new_area(start, end, AREA_VOID);
  /* The root of all evil is initially linked to itself. */
  reserved->pred = reserved->succ = reserved;
  all_areas = reserved;
#ifdef X86
  {
    managed_static_refbits = ReserveMemory((((MANAGED_STATIC_SIZE>>dnode_shift)+7)>>3));
    if (managed_static_refbits == NULL) {
#ifdef WINDOWS
      wperror("allocate refbits for managed static area");
#else
      perror("allocate refbits for managed static area");
#endif
      exit(1);
    }
  }
#endif
  return reserved;
}

void *
allocate_from_reserved_area(natural size)
{
  area *reserved = reserved_area;
  BytePtr low = reserved->low, high = reserved->high;
  natural avail = high-low;
  
  size = align_to_power_of_2(size, log2_heap_segment_size);

  if (size > avail) {
    return NULL;
  }
  reserved->low += size;
  reserved->active = reserved->low;
  reserved->ndnodes -= (size>>dnode_shift);
  return low;
}



BytePtr reloctab_limit = NULL, markbits_limit = NULL;
BytePtr low_relocatable_address = NULL, high_relocatable_address = NULL,
  low_markable_address = NULL, high_markable_address = NULL;

void
map_initial_reloctab(BytePtr low, BytePtr high)  
{
  natural ndnodes, reloctab_size;

  low_relocatable_address = low; /* will never change */
  high_relocatable_address = high;
  ndnodes = area_dnode(high,low);
  reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
  
  reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size);
  CommitMemory(global_reloctab,reloctab_limit-(BytePtr)global_reloctab);
}

void
map_initial_markbits(BytePtr low, BytePtr high)
{
  natural
    prefix_dnodes = area_dnode(low, pure_space_limit),
    ndnodes = area_dnode(high, low),
    prefix_size = (prefix_dnodes+7)>>3,
    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
    n;
  low_markable_address = low;
  high_markable_address = high;
  dynamic_mark_ref_bits = (bitvector)(((BytePtr)global_mark_ref_bits)+prefix_size);
  relocatable_mark_ref_bits = dynamic_mark_ref_bits;
  n = align_to_power_of_2(markbits_size,log2_page_size);
  markbits_limit = ((BytePtr)dynamic_mark_ref_bits)+n;
  CommitMemory(dynamic_mark_ref_bits,n);
}
    
void
lower_heap_start(BytePtr new_low, area *a)
{
  natural new_dnodes = area_dnode(low_markable_address,new_low);

  if (new_dnodes) {
    natural n = (new_dnodes+7)>>3;

    BytePtr old_markbits = (BytePtr)dynamic_mark_ref_bits,
      new_markbits = old_markbits-n;
    CommitMemory(new_markbits,n);
    dynamic_mark_ref_bits = (bitvector)new_markbits;
    if (a->refbits) {
      a->refbits= dynamic_mark_ref_bits;
    }
    a->static_dnodes += new_dnodes;
    a->ndnodes += new_dnodes;
    a->low = new_low;
    low_markable_address = new_low;
    lisp_global(HEAP_START) = (LispObj)new_low;
    static_cons_area->ndnodes = area_dnode(static_cons_area->high,new_low);
  }
}

void
ensure_gc_structures_writable()
{
  natural 
    ndnodes = area_dnode(lisp_global(HEAP_END),low_relocatable_address),
    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1)),
    n;
  BytePtr 
    new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size),
    new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)relocatable_mark_ref_bits)+markbits_size,log2_page_size);

  if (new_reloctab_limit > reloctab_limit) {
    n = new_reloctab_limit - reloctab_limit;
    CommitMemory(reloctab_limit, n);
    UnProtectMemory(reloctab_limit, n);
    reloctab_limit = new_reloctab_limit;
  }
  
  if (new_markbits_limit > markbits_limit) {
    n = new_markbits_limit-markbits_limit;
    CommitMemory(markbits_limit, n);
    UnProtectMemory(markbits_limit, n);
    markbits_limit = new_markbits_limit;
  }
}


area *
allocate_dynamic_area(natural initsize)
{
  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
  BytePtr start, end;
  area *a;

  start = allocate_from_reserved_area(totalsize);
  if (start == NULL) {
    fprintf(dbgout, "reserved area too small to load heap image\n");
    exit(1);
  }
  end = start + totalsize;
  a = new_area(start, end, AREA_DYNAMIC);
  a->active = start+initsize;
  add_area_holding_area_lock(a);
  CommitMemory(start, end-start);
  a->h = start;
  a->softprot = NULL;
  a->hardprot = NULL;
  map_initial_reloctab(a->low, a->high);
  map_initial_markbits(a->low, a->high);
  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
  return a;
 }


Boolean
grow_dynamic_area(natural delta)
{
  area *a = active_dynamic_area, *reserved = reserved_area;
  natural avail = reserved->high - reserved->low;
  
  delta = align_to_power_of_2(delta, log2_heap_segment_size);
  if (delta > avail) {
    return false;
  }

  if (!commit_pages(a->high,delta)) {
    return false;
  }


  if (!allocate_from_reserved_area(delta)) {
    return false;
  }


  a->high += delta;
  a->ndnodes = area_dnode(a->high, a->low);
  lisp_global(HEAP_END) += delta;
  ensure_gc_structures_writable();
  return true;
}

/*
  As above.  Pages that're returned to the reserved_area are
  "condemned" (e.g, we try to convince the OS that they never
  existed ...)
*/
Boolean
shrink_dynamic_area(natural delta)
{
  area *a = active_dynamic_area, *reserved = reserved_area;
  
  delta = align_to_power_of_2(delta, log2_heap_segment_size);

  a->high -= delta;
  a->ndnodes = area_dnode(a->high, a->low);
  a->hardlimit = a->high;
  uncommit_pages(a->high, delta);
  reserved->low -= delta;
  reserved->ndnodes += (delta>>dnode_shift);
  lisp_global(HEAP_END) -= delta;
  return true;
}

#ifndef WINDOWS
natural user_signal_semaphores[NSIG];
sigset_t user_signals_reserved;
#endif


#ifndef WINDOWS
void
user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context)
{
  SEMAPHORE s = (SEMAPHORE)user_signal_semaphores[signum];

  if (s != 0) {
    signal_semaphore(s);
  }
  else if (signum == SIGINT) {
    lisp_global(INTFLAG) = (((signum<<8) + 1) << fixnumshift);
  }
  else if (signum == SIGTERM) {
    lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift);
  }
  else if (signum == SIGQUIT) {
    lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift);
  }
#ifdef DARWIN
  DarwinSigReturn(context);
#endif
}

#endif


void
register_user_signal_handler()
{
#ifdef WINDOWS
  extern BOOL CALLBACK ControlEventHandler(DWORD);

  signal(SIGINT, SIG_IGN);

  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
#else
  install_signal_handler(SIGINT, (void *)user_signal_handler, 0);
  install_signal_handler(SIGTERM, (void *)user_signal_handler, 0);
  install_signal_handler(SIGQUIT, (void *)user_signal_handler, 0);
#endif
}

int
wait_for_signal(int signo, int seconds, int milliseconds)
{
#ifdef WINDOWS
  return EINVAL;
#else
  if ((signo <= 0) || (signo >= NSIG)) {
    return EINVAL;
  }
  if (sigismember(&user_signals_reserved,signo)) {
    return EINVAL;
  }
  if (user_signal_semaphores[signo] == 0) {
    user_signal_semaphores[signo] = (natural)new_semaphore(0);
    install_signal_handler(signo,(void *)user_signal_handler, 0);
  }
  return wait_on_semaphore((void *)user_signal_semaphores[signo],seconds,milliseconds);
#endif
}

BytePtr
initial_stack_bottom()
{
  extern void os_get_current_thread_stack_bounds(void **, natural*);
  void *stack_bottom;
  natural stack_size;
  
  os_get_current_thread_stack_bounds(&stack_bottom, &stack_size);
  return (BytePtr)stack_bottom;
}



  
Ptr fatal_spare_ptr = NULL;


void
Fatal(StringPtr param0, StringPtr param1)
{

  if (fatal_spare_ptr) {
    free(fatal_spare_ptr);
    fatal_spare_ptr = NULL;
  }
  fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1);
  _exit(-1);
}

void
fatal_oserr(StringPtr param, OSErr err)
{
  char buf[64];
  sprintf(buf," - operating system error %d.", err);
  Fatal(param, buf);
}

OSErr application_load_err = noErr;

area *
set_nil(LispObj);


/* Check for the existence of a file named by 'path'; return true
   if it seems to exist, without checking size, permissions, or
   anything else. */
Boolean
probe_file(char *path)
{
  struct stat st;

  return (stat(path,&st) == 0);
}


#ifdef WINDOWS
/* Chop the trailing ".exe" from the kernel image name */
wchar_t *
chop_exe_suffix(wchar_t *path)
{
  int len = wcslen(path);
  wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail;

  wcscpy(copy,path);
  tail = wcsrchr(copy, '.');
  if (tail) {
    *tail = 0;
  }
  return copy;
}
#endif

#ifdef WINDOWS
wchar_t *
path_by_appending_image(wchar_t *path)
{
  int len = wcslen(path) + wcslen(L".image") + 1;
  wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t));

  if (copy) {
    wcscpy(copy, path);
    wcscat(copy, L".image");
  }
  return copy;
}
#else
char *
path_by_appending_image(char *path)
{
  int len = strlen(path) + strlen(".image") + 1;
  char *copy = (char *) malloc(len);

  if (copy) {
    strcpy(copy, path);
    strcat(copy, ".image");
  }
  return copy;
}
#endif

#ifdef WINDOWS
wchar_t *
default_image_name(wchar_t *orig)
{
  wchar_t *path = chop_exe_suffix(orig);
  wchar_t *image_name = path_by_appending_image(path);
  return image_name;
}
#else
char *
default_image_name(char *orig)
{
  char *path = orig;
  char *image_name = path_by_appending_image(path);
  return image_name;
}
#endif

#ifdef DARWIN
char *
bundle_image_name(char *orig)
{
  char *base = basename(orig);
  char *dir = dirname(orig);
  char path[MAXPATHLEN];

  snprintf(path, MAXPATHLEN, "%s/../Resources/ccl/%s", dir, base);
  return path_by_appending_image(path);
}
#endif

char *program_name = NULL;
#ifdef WINDOWS
wchar_t *real_executable_name = NULL;
#else
char *real_executable_name = NULL;
#endif

#ifndef WINDOWS

char *
ensure_real_path(char *path)
{
  char buf[PATH_MAX*2], *p, *q;
  int n;

  p = realpath(path, buf);
  
  if (p == NULL) {
    return path;
  }
  n = strlen(p);
  q = malloc(n+1);
  strcpy(q,p);
  return q;
}

char *
determine_executable_name(char *argv0)
{
#ifdef DARWIN
  uint32_t len = 1024;
  char exepath[1024], *p = NULL;
    
  if (_NSGetExecutablePath(exepath, &len) == 0) {
    p = malloc(len+1);
    memmove(p, exepath, len);
    p[len]=0;
    return ensure_real_path(p);
  } 
  return ensure_real_path(argv0);
#endif
#ifdef LINUX
  char exepath[PATH_MAX], *p;
  int n;

  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
    p = malloc(n+1);
    memmove(p,exepath,n);
    p[n]=0;
    return p;
  }
  return argv0;
#endif
#ifdef FREEBSD
  return ensure_real_path(argv0);
#endif
#ifdef SOLARIS
  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
  int n;

  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());

  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
    p = malloc(n+1);
    memmove(p,exepath,n);
    p[n]=0;
    return p;
  }
  return ensure_real_path(argv0);
#endif
  return ensure_real_path(argv0);
}
#endif

#ifdef WINDOWS
wchar_t *
determine_executable_name()
{
  DWORD nsize = 512, result;
  wchar_t *buf = malloc(nsize*sizeof(wchar_t));

  do {
    result = GetModuleFileNameW(NULL, buf, nsize);
    if (result == nsize) {
      nsize *= 2;
      buf = realloc(buf,nsize*sizeof(wchar_t));
    } else {
      return buf;
    }
  } while (1);
}


wchar_t *
ensure_real_path(wchar_t *path)
{
  int bufsize = 256, n;

  do {
    wchar_t buf[bufsize];

    n = GetFullPathNameW(path,bufsize,buf,NULL);
    if (n == 0) {
      return path;
    }

    if (n < bufsize) {
      int i;
      wchar_t *q = calloc(n+1,sizeof(wchar_t));

      for (i = 0; i < n; i++) {
        q[i] = buf[i];
      }
      return q;
    }
    bufsize = n+1;
  } while (1);
}
#endif

void
usage_exit(char *herald, int exit_status, char* other_args)
{
  if (herald && *herald) {
    fprintf(dbgout, "%s\n", herald);
  }
  fprintf(dbgout, "usage: %s <options>\n", program_name);
#ifdef SINGLE_ARG_SHORTHAND
  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
#endif
  fprintf(dbgout, "\t where <options> are one or more of:\n");
  if (other_args && *other_args) {
    fputs(other_args, dbgout);
  }
  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
	  (u64_t) reserved_area_size);
  fprintf(dbgout, "\t\t bytes for heap expansion\n");
  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
#ifndef WINDOWS
  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
	  default_image_name(program_name));
#endif
  fprintf(dbgout, "\n\tAny arguments following the pseudoargument \"--\" are\n");
  fprintf(dbgout, "\tnot processed and are available to the application as\n");
  fprintf(dbgout, "\tthe value of CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* .\n");

  fprintf(dbgout, "\n");
  _exit(exit_status);
}

int no_sigtrap = 0;
#ifdef WINDOWS
wchar_t *image_name = NULL;
#else
char *image_name = NULL;
#endif
int batch_flag = 0;


natural
parse_numeric_option(char *arg, char *argname, natural default_val)
{
  char *tail;
  natural val = 0;

  val = strtoul(arg, &tail, 0);
  switch(*tail) {
  case '\0':
    break;
    
  case 'M':
  case 'm':
    val = val << 20;
    break;
    
  case 'K':
  case 'k':
    val = val << 10;
    break;
    
  case 'G':
  case 'g':
    val = val << 30;
    break;
    
  default:
    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
    val = default_val;
    break;
  }
  return val;
}
  


/* 
   The set of arguments recognized by the kernel is
   likely to remain pretty small and pretty simple.
   This removes everything it recognizes from argv;
   remaining args will be processed by lisp code.
*/

void
process_options(int argc, char *argv[], wchar_t *shadow[])
{
  int i, j, k, num_elide, flag, arg_error;
  char *arg, *val;
  wchar_t *warg, *wval;
#ifdef DARWIN
  extern int NXArgc;
#endif

  for (i = 1; i < argc;) {
    arg = argv[i];
    if (shadow) {
      warg = shadow[i];
    }
    arg_error = 0;
    if (*arg != '-') {
      i++;
    } else {
      num_elide = 0;
      val = NULL;
      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
	  (strcmp (arg, "--image-name") == 0)) {
	if (flag && arg[2]) {
	  val = arg+2;          
          if (shadow) {
            wval = warg+2;
          }
	  num_elide = 1;
	} else {
	  if ((i+1) < argc) {
	    val = argv[i+1];
            if (shadow) {
              wval = shadow[i+1];
            }
	    num_elide = 2;
	  } else {
	    arg_error = 1;
	  }
	}
	if (val) {
#ifdef WINDOWS
          image_name = wval;
#else
	  image_name = val;
#endif
	}
      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
		 (strcmp(arg, "--heap-reserve") == 0)) {
	natural reserved_size = reserved_area_size;

	if (flag && arg[2]) {
	  val = arg+2;
	  num_elide = 1;
	} else {
	  if ((i+1) < argc) {
	    val = argv[i+1];
	    num_elide = 2;
	  } else {
	    arg_error = 1;
	  }
	}

	if (val) {
	  reserved_size = parse_numeric_option(val, 
					       "-R/--heap-reserve", 
					       reserved_area_size);
	}

	if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
	  reserved_area_size = reserved_size;
	}

      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
		 (strcmp(arg, "--stack-size") == 0)) {
	natural stack_size;

	if (flag && arg[2]) {
	  val = arg+2;
	  num_elide = 1;
	} else {
	  if ((i+1) < argc) {
	    val = argv[i+1];
	    num_elide = 2;
	  } else {
	    arg_error = 1;
	  }
	}

	if (val) {
	  stack_size = parse_numeric_option(val, 
					    "-S/--stack-size", 
					    initial_stack_size);
	  

	  if (stack_size >= MIN_CSTACK_SIZE) {
	    initial_stack_size = stack_size;
	  }
	}

      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
		 (strcmp(arg, "--thread-stack-size") == 0)) {
	natural stack_size;

	if (flag && arg[2]) {
	  val = arg+2;
	  num_elide = 1;
	} else {
	  if ((i+1) < argc) {
	    val = argv[i+1];
	    num_elide = 2;
	  } else {
	    arg_error = 1;
	  }
	}

	if (val) {
	  stack_size = parse_numeric_option(val, 
					    "-Z/--thread-stack-size", 
					    thread_stack_size);
	  

	  if (stack_size >= MIN_CSTACK_SIZE) {
	   thread_stack_size = stack_size;
	  }
          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
          }
          
	}

      } else if (strcmp(arg, "--no-sigtrap") == 0) {
	no_sigtrap = 1;
	num_elide = 1;
      } else if ((strcmp(arg, "-b") == 0) ||
		 (strcmp(arg, "--batch") == 0)) {
	batch_flag = 1;
	num_elide = 1;
      } else if (strcmp(arg,"--") == 0) {
        break;
      } else {
	i++;
      }
      if (arg_error) {
	usage_exit("error in program arguments", 1, "");
      }
      if (num_elide) {
	for (j = i+num_elide, k=i; j < argc; j++, k++) {
	  argv[k] = argv[j];
          if (shadow) {
            shadow[k] = shadow[j];
          }
	}
	argc -= num_elide;
#ifdef DARWIN
	NXArgc -= num_elide;
#endif
	argv[argc] = NULL;
        if (shadow) {
          shadow[argc] = NULL;
        }
      }
    }
  }
}

#ifdef WINDOWS
void
terminate_lisp()
{
  _exit(EXIT_FAILURE);
}
#else
pid_t main_thread_pid = (pid_t)0;

void
terminate_lisp()
{
  kill(main_thread_pid, SIGKILL);
  _exit(-1);
}
#endif

#ifdef DARWIN
#define min_os_version "8.0"    /* aka Tiger */
#endif
#ifdef LINUX
#ifdef PPC
#define min_os_version "2.2"
#endif
#ifdef X86
#define min_os_version "2.6"
#endif
#ifdef ARM
#define min_os_version "2.6"
#endif
#endif
#ifdef FREEBSD
#define min_os_version "6.0"
#endif
#ifdef SOLARIS
#define min_os_version "5.10"
#endif

#ifdef PPC
#if defined(PPC64) || !defined(DARWIN)
/* ld64 on Darwin doesn't offer anything close to reliable control
   over the layout of a program in memory.  About all that we can
   be assured of is that the canonical subprims jump table address
   (currently 0x5000) is unmapped.  Map that page, and copy the
   actual spjump table there. */


void
remap_spjump()
{
  extern opcode spjump_start, spjump_end;
  pc new,
    old = &spjump_start,
    limit = &spjump_end,
    work;
  opcode instr;
  void *target;
  int disp;
  
  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
               0x1000,
               PROT_READ | PROT_WRITE | PROT_EXEC,
               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
               -1,
               0);
    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
      perror("remap spjump");
      _exit(1);
    }
    
    for (work = new; old < limit; work++, old++) {
      instr = *old;
      disp = instr & ((1<<26)-1);
      target = (void*)old+disp;
      disp = target-(void *)work;
      *work = ((instr >> 26) << 26) | disp;
    }
    xMakeDataExecutable((void *)new, (natural)work-(natural)new);
    ProtectMemory(new, 0x1000);
  }
}
#endif
#endif

#ifdef X86
#ifdef WINDOWS

/* By using linker tricks, we ensure there's memory between 0x11000
   and 0x21000, so we just need to fix permissions and copy the spjump
   table. */

void
remap_spjump()
{
  extern opcode spjump_start;
  DWORD old_protect;

  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
                        0x1000,
                        PAGE_READWRITE,
                        &old_protect)) {
      wperror("VirtualProtect spjump");
      _exit(1);
    }
    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
  }
}
#else
void
remap_spjump()
{
  extern opcode spjump_start;
  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
                0x1000,
                PROT_READ | PROT_WRITE,
                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
                -1,
                0),
    old = &spjump_start;
  if (new == (pc)-1) {
    perror("remap spjump");
    _exit(1);
  }
  memmove(new, old, 0x1000);
}
#endif
#endif


void
check_os_version(char *progname)
{
#ifdef WINDOWS
  /* We should be able to run with any version of Windows that actually gets here executing the binary, so don't do anything for now. */
#else
  struct utsname uts;
  long got, want;
  char *got_end,*want_end;

  want = strtoul(min_os_version,&want_end,10);

  uname(&uts);
  got = strtoul(uts.release,&got_end,10);
#if defined(X8632) && defined(FREEBSD)
  if (!strcmp(uts.machine,"amd64")) {
    extern Boolean rcontext_readonly;

    rcontext_readonly = true;
  }
#endif
#ifdef WIN_32
  rcontext_readonly = true;
#endif
  while (got == want) {
    if (*want_end == '.') {
      want = strtoul(want_end+1,&want_end,10);
      got = 0;
      if (*got_end == '.') {
        got = strtoul(got_end+1,&got_end,10);
      } else {
        break;
      }
    } else {
      break;
    }
  }

  if (got < want) {
    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
    exit(1);
  }
#endif
}

#ifdef X86
/*
  This should determine the cache block size.  It should also
  probably complain if we don't have (at least) SSE2.
*/
extern int cpuid(natural, natural*, natural*, natural*);

#define X86_FEATURE_CMOV    (1<<15)
#define X86_FEATURE_CLFLUSH (1<<19)
#define X86_FEATURE_MMX     (1<<23)
#define X86_FEATURE_SSE     (1<<25)
#define X86_FEATURE_SSE2    (1<<26)

#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)

Boolean
check_x86_cpu()
{
  natural eax, ebx, ecx, edx;

  eax = cpuid(0, &ebx, &ecx, &edx);

  if (eax >= 1) {
    eax = cpuid(1, &ebx, &ecx, &edx);
    cache_block_size = (ebx & 0xff00) >> 5;
    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
      return true;
    }
    /* It's very unlikely that SSE2 would be present and other things
       that we want wouldn't.  If they don't have MMX or CMOV either,
       might as well tell them. */
    if ((edx & X86_FEATURE_SSE2) == 0) {
      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
    }
    if ((edx & X86_FEATURE_MMX) == 0) {
      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
    }
    if ((edx & X86_FEATURE_CMOV) == 0) {
      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
    }
    
  }
  return false;
}
#endif

#ifdef ARM
int
arm_architecture_version = 0;

Boolean
check_arm_cpu()
{
  Boolean win = false;
#ifdef LINUX
/* It's hard to determine ARM features in general, and especially
   hard to do so from user mode.  Parse /proc/cpuinfo. 
   According to Android's cpufeatures library, some ARMv6 chips
   are reported to have archutecture version 7; check the ELF
   architecture in this case.

   (In other words, we assume that we're on ARMv7 or later if
   the reported architecture is > 7, or if it's = 7 and the 
   ELF architecture is "v7l".)
*/
  FILE *f = fopen("/proc/cpuinfo", "r");
  const size_t buffsz = 129;
  char procline[buffsz], cpuline[buffsz], line[buffsz];
  size_t n;

  procline[0] = '\0';
  cpuline[0]  = '\0';

  if (f) {
    while (1) {
      if (fgets(line,buffsz-1,f)==NULL) {
        break;
      }
      n = strlen(line);
      if (strncasecmp(line,"Processor",sizeof("Processor")-1) == 0) {
        strcpy(procline,line);
        procline[n]='\0';
      } else if (strncasecmp(line, "CPU architecture",sizeof("CPU architecture")-1) == 0) {
        strcpy(cpuline,line);
        cpuline[n] = '\0';
      }
    }
    if ('\0' != procline[0]) {
      win = (strstr(procline, "v7l") != NULL);
      if (win) {
        arm_architecture_version = 7;
      } else {
        win = (strstr(procline, "v6l") != NULL);
        if (win) {
          arm_architecture_version = 6;
        } else {
          if ('\0' != cpuline[0]) {
            char *workline = index(cpuline,':');
            if (workline) {
              arm_architecture_version = strtol(workline+1,NULL,0);
              if (arm_architecture_version >= ARM_ARCHITECTURE_min) {
                win = true;
              }
            }
          }
        }
      }
    }
    fclose(f);
  }
#endif
  return win;
}
#endif  

void
lazarus()
{
  TCR *tcr = get_tcr(false);
  if (tcr) {
    /* Some threads may be dying; no threads should be created. */
    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
    tcr->vs_area->active = tcr->vs_area->high - node_size;
    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
#ifndef ARM
    tcr->ts_area->active = tcr->ts_area->high;
    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
#endif
    tcr->catch_top = 0;
    tcr->db_link = 0;
    tcr->xframe = 0;
    start_lisp(tcr, 0);
  }
}

#ifdef LINUX
#ifdef X8664
#include <asm/prctl.h>
#include <sys/prctl.h>

void
ensure_gs_available(char *progname)
{
  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
  char *gnu_get_libc_version(void);
  
  arch_prctl(ARCH_GET_GS, &gs_addr);
  arch_prctl(ARCH_GET_FS, &fs_addr);
  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
    fprintf(dbgout, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname);
    _exit(1);
  }
}
#endif
#endif

Boolean 
bogus_fp_exceptions = false;

typedef
float (*float_arg_returns_float)(float);

float
fcallf(float_arg_returns_float fun, float arg)
{
  return fun(arg);
}

void
check_bogus_fp_exceptions()
{
#ifdef X8664
  float asinf(float),result;
    

  natural save_mxcsr = get_mxcsr(), post_mxcsr;
  set_mxcsr(0x1f80);

  result = fcallf(asinf, 1.0);
  post_mxcsr = get_mxcsr();
  set_mxcsr(save_mxcsr);
  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
    bogus_fp_exceptions = true;
  }
#endif
}

#ifdef WINDOWS
char *
utf_16_to_utf_8(wchar_t *utf_16)
{
  int utf8len = WideCharToMultiByte(CP_UTF8,
                                    0,
                                    utf_16,
                                    -1,
                                    NULL,
                                    0,
                                    NULL,
                                    NULL);

  char *utf_8 = malloc(utf8len);

  WideCharToMultiByte(CP_UTF8,
                      0,
                      utf_16,
                      -1,
                      utf_8,
                      utf8len,
                      NULL,
                      NULL);

  return utf_8;
}

char **
wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
{
  char** argv = calloc(argc+1,sizeof(char *));
  int i;

  for (i = 0; i < argc; i++) {
    if (wide_argv[i]) {
      argv[i] = utf_16_to_utf_8(wide_argv[i]);
    } else {
      argv[i] = NULL;
    }
  }
  return argv;
}
#endif

natural default_g0_threshold = G0_AREA_THRESHOLD;
natural default_g1_threshold = G1_AREA_THRESHOLD;
natural default_g2_threshold = G2_AREA_THRESHOLD;
natural lisp_heap_threshold_from_image = 0;

void
init_consing_areas()
{
  area *a;
  a = active_dynamic_area;

  if (nilreg_area != NULL) {
    BytePtr lowptr = (BytePtr) a->low;

    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
    add_area_holding_area_lock(tenured_area);
    add_area_holding_area_lock(g2_area);
    add_area_holding_area_lock(g1_area);

    g1_area->code = AREA_DYNAMIC;
    g2_area->code = AREA_DYNAMIC;
    tenured_area->code = AREA_DYNAMIC;

/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
    g1_area->younger = a;
    g1_area->older = g2_area;
    g2_area->younger = g1_area;
    g2_area->older = tenured_area;
    tenured_area->younger = g2_area;
    tenured_area->refbits = dynamic_mark_ref_bits;
    managed_static_area->refbits = global_mark_ref_bits;
    a->markbits = dynamic_mark_ref_bits;
    tenured_area->static_dnodes = a->static_dnodes;
    a->static_dnodes = 0;
    tenured_area->static_used = a->static_used;
    a->static_used = 0;
    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
    lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area);
    lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits);
    g2_area->threshold = default_g2_threshold;
    g1_area->threshold = default_g1_threshold;
    a->threshold = default_g0_threshold;
  }
}

int
#ifdef CCLSHARED
cclmain
#else
main
#endif
(int argc, char *argv[]
#if defined(PPC) && defined(LINUX)
, char *envp[], void *aux
#endif
)
{
  extern int page_size;
  Boolean egc_enabled =
#ifdef DISABLE_EGC
    false
#else
    true
#endif
    ;
  Boolean lisp_heap_threshold_set_from_command_line = false;
  wchar_t **utf_16_argv = NULL;

#ifdef PPC
  extern int altivec_present;
#endif
#ifdef WINDOWS
  extern LispObj load_image(wchar_t *);
#else
  extern LispObj load_image(char *);
#endif
  area *a;
  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
  TCR *tcr;

  dbgout = stderr;

#ifdef WINDOWS
  {
    int wide_argc;
    extern void init_winsock(void);
    extern void init_windows_io(void);
    extern void reserve_tls_slots(void);

    _fmode = O_BINARY;
    _setmode(1, O_BINARY);
    _setmode(2, O_BINARY);
    setvbuf(dbgout, NULL, _IONBF, 0);
    init_winsock();
    init_windows_io();
    reserve_tls_slots();
    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
  }
#endif

  check_os_version(argv[0]);
#ifdef WINDOWS
  real_executable_name = determine_executable_name();
#else
  real_executable_name = determine_executable_name(argv[0]);
#endif
  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */

  check_bogus_fp_exceptions();
#ifdef LINUX
#ifdef X8664
  ensure_gs_available(real_executable_name);
#endif
#endif
#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
  remap_spjump();
#endif

#ifdef PPC
#ifdef LINUX
  {
    ElfW(auxv_t) *av = aux;
    int hwcap, done = false;
    
    if (av) {
      do {
	switch (av->a_type) {
	case AT_DCACHEBSIZE:
	  cache_block_size = av->a_un.a_val;
	  break;

	case AT_HWCAP:
	  hwcap = av->a_un.a_val;
	  altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
	  break;

	case AT_NULL:
	  done = true;
	  break;
	}
	av++;
      } while (!done);
    }
  }
#endif
#ifdef DARWIN
  {
    unsigned value = 0;
    size_t len = sizeof(value);
    int mib[2];
    
    mib[0] = CTL_HW;
    mib[1] = HW_CACHELINE;
    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
      if (len == sizeof(value)) {
	cache_block_size = value;
      }
    }
    mib[1] = HW_VECTORUNIT;
    value = 0;
    len = sizeof(value);
    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
      if (len == sizeof(value)) {
	altivec_present = value;
      }
    }
  }
#endif
#endif

#ifdef X86
  if (!check_x86_cpu()) {
    fprintf(dbgout, "CPU doesn't support required features\n");
    exit(1);
  }
#endif

#ifdef ARM
  if (!check_arm_cpu()) {
    fprintf(dbgout, "CPU doesn't support required features\n");
    exit(1);
  }
#endif

#ifdef SOLARIS
#ifdef X8632
  {
    extern void solaris_ldt_init(void);
    solaris_ldt_init();
  }
#endif
#endif

#ifndef WINDOWS
  main_thread_pid = getpid();
#endif
  tcr_area_lock = (void *)new_recursive_lock();

  program_name = argv[0];
#ifdef SINGLE_ARG_SHORTHAND
  if ((argc == 2) && (*argv[1] != '-')) {
#ifdef WINDOWS
    image_name = utf_16_argv[1];
#else
    image_name = argv[1];
#endif
    argv[1] = NULL;
#ifdef WINDOWS
    utf_16_argv[1] = NULL;
#endif
  } else {
#endif  /* SINGLE_ARG_SHORTHAND */
    process_options(argc,argv,utf_16_argv);
#ifdef SINGLE_ARG_SHORTHAND
  }
#endif
  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
    lisp_heap_threshold_set_from_command_line = true;
  }

  initial_stack_size = ensure_stack_limit(initial_stack_size);
  if (image_name == NULL) {
    if (check_for_embedded_image(real_executable_name)) {
      image_name = real_executable_name;
    } else {
      image_name = default_image_name(real_executable_name);
#ifdef DARWIN
      if (!probe_file(image_name)) {
	image_name = bundle_image_name(real_executable_name);
      }
#endif
    }
  }

  while (1) {
    if (create_reserved_area(reserved_area_size)) {
      break;
    }
    reserved_area_size = reserved_area_size *.9;
  }

  gc_init();

  set_nil(load_image(image_name));
  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
  
  if (lisp_heap_threshold_from_image) {
    if ((!lisp_heap_threshold_set_from_command_line) &&
        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
    }
    /* If lisp_heap_threshold_from_image was set, other image params are
       valid. */
    default_g0_threshold = lisp_global(G0_THRESHOLD);
    default_g1_threshold = lisp_global(G1_THRESHOLD);
    default_g2_threshold = lisp_global(G2_THRESHOLD);
    egc_enabled = lisp_global(EGC_ENABLED);
  }

  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);

#ifdef X86
  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
#endif
#ifdef PPC
  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
#endif
#ifdef ARM
  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
#endif

  lisp_global(RET1VALN) = (LispObj)&ret1valn;
  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;


  exception_init();

  

#ifdef WINDOWS
  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
#else
  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
  lisp_global(ARGV) = ptr_to_lispobj(argv);
#endif
  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;

  lisp_global(GET_TCR) = (LispObj) get_tcr;
  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;

  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;

  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);

  init_consing_areas();
  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
  stack_base = initial_stack_bottom()-xStackSpace();
  init_threads((void *)(stack_base), tcr);
  thread_init_tcr(tcr, current_sp, current_sp-stack_base);

  if (lisp_global(STATIC_CONSES) == 0) {
    lisp_global(STATIC_CONSES) = lisp_nil;
  }

  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
  enable_fp_exceptions();
  register_user_signal_handler();

#ifdef PPC
  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
#endif
#ifdef ARM
#if defined (__ARM_PCS_VFP)
 /* would be nice if there was a way to test for this (armhf) at runtime */
  lisp_global(FLOAT_ABI) = 1 << fixnumshift;
#endif
#endif
#if STATIC
  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
#endif
  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
#ifndef WINDOWS
  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
#endif
  tcr->vs_area->active -= node_size;
  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
  nrs_TOPLFUNC.vcell = lisp_nil;
#ifdef GC_INTEGRITY_CHECKING
  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
#endif
  if (egc_enabled) {
    egc_control(true, NULL);
  } else {
    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
  }
  lisp_global(MANAGED_STATIC_REFBITS) = (LispObj)managed_static_refbits;
  lisp_global(MANAGED_STATIC_DNODES) = (LispObj)managed_static_area->ndnodes;
  atexit(lazarus);
#ifdef ARM
#ifdef LINUX
#ifdef SET_INITIAL_THREAD_AFFINITY
  /* Maybe work around an apparent cache coherency problem */
  set_thread_affinity(tcr,0);
#endif
#endif
#endif
  start_lisp(TCR_TO_TSD(tcr), 0);
  _exit(0);
}

area *
set_nil(LispObj r)
{

  if (lisp_nil == (LispObj)NULL) {

    lisp_nil = r;
  }
  return NULL;
}


void
xMakeDataExecutable(BytePtr start, natural nbytes)
{
#ifdef PPC
  extern void flush_cache_lines();
  natural ustart = (natural) start, base, end;
  
  base = (ustart) & ~(cache_block_size-1);
  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
#endif
#ifdef ARM
  extern void flush_cache_lines(void *, size_t);
  flush_cache_lines(start,nbytes);
#endif
}

natural
xStackSpace()
{
  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
}

#ifndef DARWIN
#ifdef WINDOWS
extern void *windows_open_shared_library(char *);

void *
xGetSharedLibrary(char *path, int mode)
{
  return windows_open_shared_library(path);
}
#else
void *
xGetSharedLibrary(char *path, int mode)
{
  return dlopen(path, mode);
}
#endif
#else
void *
xGetSharedLibrary(char *path, int *resultType)
{
  const char *error;
  void *result;

  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
  
  if (result == NULL) {
    error = dlerror();
    *resultType = 0;
    return (void *)error;
  }
  *resultType = 1;
  return result;
}
#endif



int
fd_setsize_bytes()
{
  return sizeof(fd_set);
}

void
do_fd_set(int fd, fd_set *fdsetp)
{
  FD_SET(fd, fdsetp);
}

void
do_fd_clr(int fd, fd_set *fdsetp)
{
  FD_CLR(fd, fdsetp);
}

int
do_fd_is_set(int fd, fd_set *fdsetp)
{
  return FD_ISSET(fd,fdsetp);
}


void
do_fd_zero(fd_set *fdsetp)
{
  FD_ZERO(fdsetp);
}

#include "image.h"



Boolean
check_for_embedded_image (
#ifdef WINDOWS
                          wchar_t *path
#else
                          char *path
#endif
                          )
{
#ifdef WINDOWS
  int fd = wopen(path, O_RDONLY);
#else  
  int fd = open(path, O_RDONLY);
#endif

  Boolean image_is_embedded = false;

  if (fd >= 0) {
    openmcl_image_file_header h;

    if (find_openmcl_image_file_header (fd, &h)) {
      image_is_embedded = true;
    }
    close (fd);
  }
  return image_is_embedded;
}

LispObj
load_image(
#ifdef WINDOWS
           wchar_t * path
#else
           char *path
#endif
)
{
#ifdef WINDOWS
  int fd = wopen(path, O_RDONLY, 0666), err;
#else
  int fd = open(path, O_RDONLY, 0666), err;
#endif
  LispObj image_nil = 0;

  if (fd > 0) {
    openmcl_image_file_header ih;

    errno = 0;
    image_nil = load_openmcl_image(fd, &ih);
    /* We -were- using a duplicate fd to map the file; that
       seems to confuse Darwin (doesn't everything ?), so
       we'll instead keep the original file open.
    */
    err = errno;
    if (!image_nil) {
      close(fd);
    }
#ifdef WINDOWS
    /* We currently don't actually map the image, and leaving the file
       open seems to make it difficult to write to reliably. */
    if (image_nil) {
      close(fd);
    }
#endif
  } else {
    err = errno;
  }
#ifdef DARWIN
#ifdef X86
  if (image_nil == 0) {
    extern LispObj load_native_library(char *);
    image_nil = load_native_library(path);
  }
#endif
#endif
  if (image_nil == 0) {
#ifdef WINDOWS
    char *fmt = "Couldn't load lisp heap image from %ls";
#else
    char *fmt = "Couldn't load lisp heap image from %s";
#endif

    fprintf(dbgout, fmt, path);
    if (err == 0) {
      fprintf(dbgout, "\n");
    } else {
      fprintf(dbgout, ": %s\n", strerror(err));
    }
    exit(-1);
  }
  return image_nil;
}

int
set_errno(int val)
{
  errno = val;
  return -1;
}

/* A horrible hack to allow us to initialize a JVM instance from lisp.
   On Darwin, creating a JVM instance clobbers the thread's existing
   Mach exception infrastructure, so we save and restore it here.
*/

typedef int (*jvm_initfunc)(void*,void*,void*);

int
jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
{
  int result = -1;
  TCR *tcr = get_tcr(1);
  
  result = f(arg0,arg1,arg2);
  return result;
}


void *
xFindSymbol(void* handle, char *name)
{
#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
#ifdef ANDROID
  if (handle == NULL) {
    handle = RTLD_DEFAULT;
  }
#endif
  return dlsym(handle, name);
#endif
#ifdef DARWIN
  void *result;

  if ((handle == NULL) || (handle == ((void *) -1))) {
    handle = RTLD_DEFAULT;
  }    
  result = dlsym(handle, name);
  if ((result == NULL) && (*name == '_')) {
    result = dlsym(handle, name+1);
  }
  return result;
#endif
#ifdef WINDOWS
  extern void *windows_find_symbol(void *, char *);
  return windows_find_symbol(handle, name);
#endif
}
#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
#if WORD_SIZE == 64
typedef Elf64_Dyn Elf_Dyn_thing;
typedef Elf64_Ehdr Elf_Ehdr_thing;
typedef Elf64_Shdr Elf_Shdr_thing;
#else
typedef Elf32_Dyn Elf_Dyn_thing;
typedef Elf32_Ehdr Elf_Ehdr_thing;
typedef Elf32_Shdr Elf_Shdr_thing;
#endif

Elf_Dyn_thing *
get_executable_dynamic_entries()
{
#ifndef CCLSHARED
  extern Elf_Dyn_thing _DYNAMIC[];
  return _DYNAMIC;
#else
#ifdef ANDROID
  /* Deep, dark secret: the "handle" returned by dlopen() is
     a pointer to an soinfo structure, as defined in linker.h.
     We can get the link map from there ...
  */
  

 
  /* Woe unto us - and lots of it - if the executable is mapped
     at an address other than 0x8000.  Todo: parse /proc/self/maps. */
  char *p;
  Elf_Ehdr_thing *elf_header;
  Elf_Shdr_thing *section_header;
  int i,fd;
  struct stat _stat;
  Elf_Dyn_thing *result = NULL;
  
  fd = open("/proc/self/exe",O_RDONLY);
  if (fd >= 0) {
    if (fstat(fd,&_stat) == 0) {
      p = (char *)mmap(NULL,_stat.st_size,PROT_READ,MAP_PRIVATE,fd,0);
      if (p != MAP_FAILED) {
        elf_header = (Elf_Ehdr_thing *)p;
        for (section_header = (Elf_Shdr_thing *)(p+elf_header->e_shoff),
               i = 0;
             i < elf_header->e_shnum;
             i++,section_header++) {
          if (section_header->sh_type == SHT_DYNAMIC) {
            result = (Elf_Dyn_thing *)section_header->sh_addr;
            break;
          }
        }
        munmap(p,_stat.st_size);
      }
    }
    close(fd);
  }
  return result;
#else
#error need implementation for get_executable_dynamic_entries from dso
#endif
#endif
}


void *cached_r_debug = NULL;

void *
get_r_debug()
{
  int tag;
  Elf_Dyn_thing *dp;

  if (cached_r_debug == NULL) {
    for (dp = get_executable_dynamic_entries(); (tag = dp->d_tag) != 0; dp++) {
      if (tag == DT_DEBUG) {
        cached_r_debug = (void *)(dp->d_un.d_ptr);
        break;
      }
    }
  }
  return cached_r_debug;
}

#else
void *
get_r_debug()
{
  return NULL;
}
#endif

#ifdef WINDOWS
void
sample_paging_info(paging_info *stats)
{
}

void
report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
{
}
#else
void
sample_paging_info(paging_info *stats)
{
  getrusage(RUSAGE_SELF, stats);
}

void
report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
{
  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
          stop->ru_minflt-start->ru_minflt,
          stop->ru_majflt-start->ru_majflt,
          stop->ru_nswap-start->ru_nswap);
}

#endif

void
allocate_static_conses(natural n)
{
  BytePtr old_low = static_cons_area->low,
    new_low = old_low - (n<<dnode_shift);
  cons *c;
  natural i;
  LispObj prev;

  CommitMemory(new_low,old_low-new_low);

  static_cons_area->low = new_low;
  lower_heap_start(new_low, tenured_area);
  /* what a mess this is ... */
  if (active_dynamic_area->low == old_low) {
    active_dynamic_area->low = new_low;
  }
  if (!active_dynamic_area->older) {
    active_dynamic_area->markbits = tenured_area->refbits;
  }
  if (g1_area->low == old_low) {
    g1_area->low = new_low;
  }
  if (g1_area->high == old_low) {
    g1_area->high = new_low;
  }
  if (g2_area->low == old_low) {
    g2_area->low = new_low;
  }
  if (g2_area->high == old_low) {
    g2_area->high = new_low;
  }
  for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low;
       i < n;
       i++, c++) {
    c->car = unbound;
    c->cdr = prev;
    prev = ((LispObj)c)+fulltag_cons;
  }
  lisp_global(STATIC_CONSES)=prev;
  lisp_global(FREE_STATIC_CONSES)+=(n<<fixnumshift);
}

#ifdef X86
#define USE_GC_NOTIFICATION 1
#else
#undef USE_GC_NOTIFICATION
#endif

void
ensure_static_conses(ExceptionInformation *xp, TCR *tcr, natural nconses)
{
  area *a = active_dynamic_area;
  natural nbytes = nconses>>dnode_shift, have;
  BytePtr p = a->high-nbytes;
#ifdef USE_GC_NOTIFICATION
  Boolean crossed_notify_threshold = false;
  LispObj before_shrink, after_shrink;
#endif

  if (p < a->active) {
    untenure_from_area(tenured_area);
    gc_from_xp(xp, 0L);
#ifdef USE_GC_NOTIFICATION
    did_gc_notification_since_last_full_gc = false;
#endif
  }

  have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES));
  if (have < nconses) {
#ifdef USE_GC_NOTIFICATION
    before_shrink = a->high-a->active;
    if (before_shrink>nbytes) {
      shrink_dynamic_area(nbytes);
      after_shrink = a->high-a->active; 
      if ((before_shrink >= lisp_heap_notify_threshold) &&
          (after_shrink < lisp_heap_notify_threshold)) {
        crossed_notify_threshold = true;
      }
    }
#endif
    allocate_static_conses(nconses);
    TCR_AUX(tcr)->bytes_allocated += nbytes;
  }
#ifdef USE_GC_NOTIFICATION
  if (crossed_notify_threshold && !did_gc_notification_since_last_full_gc) {
    callback_for_gc_notification(xp,tcr);
  }
#endif
}
      
#ifdef ANDROID
#include <jni.h>
#include <android/log.h>
#include "android_native_app_glue.h"

extern int init_lisp(TCR *);

JavaVM *android_vm = NULL;

void
wait_for_debugger()
{ 
  volatile Boolean ready = false;

  __android_log_print(ANDROID_LOG_INFO,"nativeCCL","waiting for debugger");
  do {
    sleep(1);
  } while(!ready);
}  
 

Boolean
init_ccl_for_android(ANativeActivity *activity)
{
  extern int page_size;
  Boolean egc_enabled =
#ifdef DISABLE_EGC
    false
#else
    true
#endif
    ;
  TCR *tcr;
  BytePtr stack_base, current_sp;
  char **argv;

  wait_for_debugger();
  android_vm = activity->vm;

  current_sp = (BytePtr) current_stack_pointer();
  page_size = getpagesize();
  
  if (!check_arm_cpu()) {
    __android_log_print(ANDROID_LOG_FATAL,"nativeCCL","CPU doesn't support required features");
    return false;
  }
  main_thread_pid = getpid();
  tcr_area_lock = (void *)new_recursive_lock();
  image_name = "/data/local/ccl/android.image"; /* need something better. */
  while (1) {
    if (create_reserved_area(reserved_area_size)) {
      break;
    }
    reserved_area_size = reserved_area_size *.9;
  }

  gc_init();

  set_nil(load_image(image_name));
  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
  
  if (lisp_heap_threshold_from_image) {
    if (lisp_heap_threshold_from_image != lisp_heap_gc_threshold) {
      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
    }
    /* If lisp_heap_threshold_from_image was set, other image params are
       valid. */
    default_g0_threshold = lisp_global(G0_THRESHOLD);
    default_g1_threshold = lisp_global(G1_THRESHOLD);
    default_g2_threshold = lisp_global(G2_THRESHOLD);
    egc_enabled = lisp_global(EGC_ENABLED);
  }
  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
#ifdef ARM
  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
#endif
  lisp_global(RET1VALN) = (LispObj)&ret1valn;
  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;


  exception_init();
  argv = (char**)(malloc (sizeof (char *)));
  argv[0] = NULL;
  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
  lisp_global(ARGV) = ptr_to_lispobj(argv);
  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;

  lisp_global(GET_TCR) = (LispObj) get_tcr;
  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;

  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;

  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);

  init_consing_areas();
  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
  stack_base = initial_stack_bottom()-xStackSpace();
  init_threads((void *)(stack_base), tcr);
  thread_init_tcr(tcr, current_sp, current_sp-stack_base);

  if (lisp_global(STATIC_CONSES) == 0) {
    lisp_global(STATIC_CONSES) = lisp_nil;
  }


  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
  enable_fp_exceptions();
  register_user_signal_handler();
  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
#ifdef GC_INTEGRITY_CHECKING
  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
#endif
  if (egc_enabled) {
    egc_control(true, NULL);
  } else {
    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
  }

  if (init_lisp(TCR_TO_TSD(tcr)) == 0) {
    return true;
  }
  return false;
}


/* 
   This runs on a secondary thread that isn't bound to the JVM.
   Splitting the event loop in two like this is supposed to
   weaken timing constraints somehow.  It's not clear that it
   actually does so, but Android NDK examples generally use
   this mechanism.
*/
   
void 
android_main(struct android_app* state) 
{
  TCR *tcr;
  JNIEnv *env;

  tcr = new_tcr(DEFAULT_INITIAL_STACK_SIZE, MIN_TSTACK_SIZE);
  thread_init_tcr(tcr, current_stack_pointer,DEFAULT_INITIAL_STACK_SIZE);
  (*android_vm)->AttachCurrentThread(android_vm, &env, NULL);

  os_main(tcr, state);
  (*android_vm)->DetachCurrentThread(android_vm);
}
#endif

同样,我们需要重新编译内核。非常感谢Mark Brown的问题描述和修复。

保存CCL应用程序

保存CCL应用程序非常简单。以下函数调用将保存可执行的CCL应用程序。生成的文件将包含所有加载的Lisp代码,所有Lisp对象,并将内核添加到文件中。这意味着您可以将库和应用程序代码加载到CCL中,然后创建应用程序。这样我们就可以在一个文件中获得一个完全独立的可执行Clozure Common Lisp应用程序。请注意,不需要保存图像 – 您可以使用现有的可执行文件。如果要保存您或其他人编写的实际Lisp应用程序,保存这样的图像会很方便。

(ccl:save-application "ccl-app" :prepend-kernel t)

保存应用程序 – CCL手册详细介绍了保存应用程序。该功能还有一些用于自定义生成的应用程序的选项。

使用Quicklisp,GNU Emacs和SLIME的Clozure Common Lisp的开发环境

接下来,我们将了解如何获得基于Quicklisp,SLIME和GNU Emacs的开发环境。

Quicklisp – 感谢Zach Beane现在有一个工具,Common Lisp用户可以使用它来获取各种Common Lisp代码库。Quicklisp提供700多个图书馆。

移动到一个方便的目录,您希望保留Lisp代码并下载Quicklisp。

$ curl http://beta.quicklisp.org/quicklisp.lisp >quicklisp.lisp

启动CCL并加载/安装Quicklisp。我们将它添加到我们的CCL初始化文件〜/ .ccl-init.lisp中

? (load "quicklisp.lisp")
? (quicklisp-quickstart:install)

CCL init文件位于我们的主目录中,名为.ccl-init.lisp。创建此文件并添加以下功能:

(defun load-quicklisp ()
  (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
                                         (user-homedir-pathname))))
    (when (probe-file quicklisp-init)
      (load quicklisp-init))))

这样您就可以在需要时加载Quicklisp。默认加载它会给CCL增加一些启动时间,我想避免。另一种避免它的方法是保存一个加载了某些功能的新图像。

Quicklisp命令,很高兴知道:

(ql:update-all-dists)            ; Update all software
(ql:update-client)               ; Update the Quicklisp client
(ql:system-apropos substring)    ; List matching software
(ql:who-depends-on system-name)  ; List systems which depend on a certain software system

SLIME – Emacs的高级Lisp交互模式。SLIME通过开发Common Lisp程序所需的编辑器支持扩展了GNU Emacs。您将获得许多工具,包括Lisp监听器,用于编辑Common Lisp的编辑器模式和调试器支持。SLIME有两个部分:一部分是扩展编辑器,另一部分是在我们的Common Lisp中运行。然后Emacs可以连接到正在运行的Common Lisp。

SLIME手册 – SLIME的文档。

加载Quicklisp后,我们现在可以使用CCL轻松完成SLIME安装。

? (ql:quickload "quicklisp-slime-helper")

接下来我们设置GNU Emacs以使用SLIME。编辑.emacs文件(必要时创建它)。加载SLIME,然后将SLIME指向CCL可执行文件所在的位置。就我而言,它位于/ home / pi / ccl / armcl中。将这些行添加到〜/ .emacs:

(load (expand-file-name "~/quicklisp/slime-helper.el"))
(setq inferior-lisp-program "/home/pi/ccl/armcl")  ; use the right path to your CCL executable here

GNU Emacs – 我们可扩展,可自定义的文本编辑器。

现在我们应该把一切都安排到位。启动GNU Emacs并尝试将SLIME与Clozure CL一起使用。要在Emacs中运行SLIME,请调用Mx slime。这意味着你要么按一个元键(如果有的话)或输入序列ESCAPE x slime RETURN。在第一次使用时,将编译一些Lisp文件 – 稍后它们将被加载 – 并且您将获得一个REPL缓冲区。REPL代表READ EVAL PRINT LOOP。这是Lisp的命令行界面。您既可以使用典型终端窗口中的GNU Emacs,也可以使用GNU Emacs和X11窗口界面。后者为您提供了更丰富的用户界面。通常,通过终端使用Emacs就足够了。如果你这样做我会建议使用’screen’实用程序(通过apt-get获取)。’screen’允许您使用终端和’screen -r’重新连接到Raspberry Pi 你回到你的Lisp编程会话。强烈建议这样做,并允许您更快地回到破解Lisp代码。

我们可以在CCL提示符下使用:help命令在CCL中获得简单的帮助。

? :help
The following toplevel commands are available:
 :?     help
 :PWD   Print the pathame of the current directory
 (:CD DIR)  Change to directory DIR (e.g., #p"ccl:" or "/some/dir")
 (:PROC &OPTIONAL P)  Show information about specified process <p>/all processes
 (:KILL P)  Kill process whose name or ID matches <p>
 (:Y &OPTIONAL P)  Yield control of terminal-input to process
whose name or ID matches <p>, or to any process if <p> is null
Any other form is evaluated and its results are printed out.

CCL中的调试器还有一些命令。

1 > :help
The following toplevel commands are available:
 <n>    the same as (:C <n>)
 (:FUNCTION FRAME-NUMBER)  Returns the function invoked in backtrace
 frame <frame-number>. This may be useful for, e.g., disassembly
 (:FORM FRAME-NUMBER)  Return a form which looks like the call which established the
  stack frame identified by <frame-number>.  This is only well-defined in certain cases:
  when the function is globally named and not a lexical closure and when it was compiled
  with *SAVE-LOCAL-SYMBOLS* in effect.
 (:SET-LOCAL NAME FRAME-NUMBER NEW)  Set value of argument denoted <name> (see :LOCAL)
  in frame <frame-number> to value <new>.
 (:LOCAL NAME FRAME-NUMBER)  Return value of local denoted by  in frame <frame-number>
  <name> can either be a symbol - in which case the most recent
  binding of that symbol is used - or an integer index into the frame's set of local
  bindings.
 (:SET-ARG NAME FRAME-NUMBER NEW)  Set value of argument named <name> in
  frame <frame-number> to value <new>.
 (:ARG NAME FRAME-NUMBER)  Return value of argument named <name> in
  frame <frame-number>
 (:V N FRAME-NUMBER)  Return value <n> in frame <frame-number>
 (:RAW N)  Show raw contents of backtrace frame <n>
 (:APPLY-IN-FRAME I FUNCTION &REST ARGS)  Applies FUNCTION to ARGS in the execution
  context of the Ith stack frame
 (:RETURN-FROM-FRAME I &REST VALUES)  Return VALUES from the I'th stack frame
 (:F N)  Show backtrace frame <n>
 (:C &OPTIONAL N)  Choose restart <n>. If no <n>, continue
 (:B &KEY START COUNT SHOW-FRAME-CONTENTS)  backtrace
 :NFRAMES   print the number of stack frames accessible from this break loop
 :R     list restarts
 :Q     return to toplevel
 :GO    continue
 :A     exit current break loop
 :POP   exit current break loop
 :?     help
 :PWD   Print the pathame of the current directory
 (:CD DIR)  Change to directory DIR (e.g., #p"ccl:" or "/some/dir")
 (:PROC &OPTIONAL P)  Show information about specified process <p>/all processes
 (:KILL P)  Kill process whose name or ID matches <p>
 (:Y &OPTIONAL P)  Yield control of terminal-input to process
 whose name or ID matches <p>, or to any process if <p> is null
 Any other form is evaluated and its results are printed out.

在GNU Emacs中,您可以使用常用的Emacs命令来获取帮助。有趣的是’ch m’。它描述了当前缓冲模式可用的命令。

下一步是什么?接下来我建议您阅读一些SLIME手册,以熟悉它提供的基本功能。开始编写一个小的Lisp程序,学习如何使用SLIME编译和调试它。

在Linux下可用于Raspberry Pi(和相关计算机)的其他Common Lisp实现

使用apt-get:clisp,ecl和gcl工具也可以安装几个Common Lisp实现。请注意,您可以通过这种方式获得旧版本。从源代码安装可能是首选。

ABCL – JVM上Common Lisp的实现。

对于ABCL,您需要为计算机安装JVM。Oracle提供了一个。根据ARM计算机的速度和JVM版本的版本,使用起来可能有点慢。

GNU CLISP – Common Lisp的一个非常便携的实现。

您可以通过Raspberry Pi上的apt-get安装GNU CLISP。我发现自己编译它很痛苦,所以我没有在其他ARM计算机上使用它

ECL – 另一个非常便携的实现。

您也可以通过apt-get安装ECL。它应该能够自己编译。

GCL – 一个较旧的Common Lisp实现。

GCL缺少一些ANSI CL功能。它可以编译为在ARM上运行。GCL过去几年没有看到太多的维护,认为2013年底有一些活动。要记住一件事:你需要使用更新版本并告诉它使用ANSI CL功能 – 否则GCL坚持一些旧版的Common Lisp。您可以通过这种方式识别旧方言:旧方言使用包LISP和USER。旧版本也宣称自己坚持使用CLtL1,这是Common Lisp的早期版本。后来的ANSI CL提供了包COMMON-LISP和COMMON-LISP-USER。有关详细信息,请参阅GCL手册或启动选项。

LispWorks – 具有GUI工具包和开发环境的全功能Common Lisp实现。

LispWorks是商业/专有软件。它的开发环境使用GTK +运行良好。可以开发跨平台的GUI应用程序。它编译为快速的本机代码,并有许多交付选项。

哪些Common Lisp实现可用于ARM系统?

口齿不清 类型 Android的 iOS版 GNU / Linux的/ ARM
ABCL JVM上的完整CL 没有
CCL 完整的CL,本机代码 不支持 不支持 CCL 1.10
CLISP 完整的CL,字节代码 没有 没有
ECL 完整的CL,C 可能
保利协鑫 完整的CL,C 没有 没有
LispWorks 在Linux上使用本机代码的完整CL。Android / iOS上的原生应用程序。 是的,7.0 是的,7.0 是的,7.0
代替MoCl C申请 没有
SBCL 完整的CL,本机代码 没有 没有 SBCL更高1.2.0
预订学习Common Lisp的建议

Common Lisp:由David S. Touretzky撰写的一本关于符号计算的温和介绍 – 一本学习Common Lisp基础知识的优秀免费书。

由Conrad Barski创作的Lisp之乡 – 用最有趣的入门书来学习Common Lisp。

CCL在带有SLIME的终端中

你的Lisp体验现在开始了,有一个开括号……


Leave a Reply

搜索

分类目录

公 告

本网站学习论坛:

www.zhlisp.com

lisp中文学习源码:

https://github.com/zhlisp/

欢迎大家来到本站,请积极评论发言;

加QQ群学习交流。