basis/tools/deploy/backend/backend.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces make continuations.private kernel.private init
   4 assocs kernel vocabs words sequences memory io system arrays
   5 continuations math definitions mirrors splitting parser classes
   6 summary layouts vocabs.loader prettyprint.config prettyprint
   7 debugger io.streams.c io.files io.backend quotations io.launcher
   8 words.private tools.deploy.config bootstrap.image
   9 io.encodings.utf8 destructors accessors ;
  10 IN: tools.deploy.backend
  11
  12 : copy-vm ( executable bundle-name extension -- vm )
  13   [ prepend-path ] dip append vm over copy-file ;
  14
  15 : copy-fonts ( name dir -- )
  16   append-path "resource:fonts/" swap copy-tree-into ;
  17
  18 : image-name ( vocab bundle-name -- str )
  19   prepend-path ".image" append ;
  20
  21 : copy-lines ( -- )
  22     readln [ print flush copy-lines ] when* ;
  23
  24 : run-with-output ( arguments -- )
  25     <process>
  26         swap >>command
  27         +stdout+ >>stderr
  28         +closed+ >>stdin
  29         +low-priority+ >>priority
  30     utf8 [ copy-lines ] with-process-reader ;
  31
  32 : make-boot-image ( -- )
  33     #! If stage1 image doesn't exist, create one.
  34     my-boot-image-name resource-path exists?
  35     [ my-arch make-image ] unless ;
  36
  37 : bootstrap-profile ( -- profile )
  38     {
  39         { "math"     deploy-math?     }
  40         { "compiler" deploy-compiler? }
  41         { "threads"  deploy-threads?  }
  42         { "ui"       deploy-ui?       }
  43         { "random"   deploy-random?   }
  44     } [ nip get ] assoc-filter keys
  45     native-io? [ "io" suffix ] when ;
  46
  47 : staging-image-name ( profile -- name )
  48     "staging."
  49     swap strip-word-names? [ "strip" suffix ] when
  50     "-" join ".image" 3append temp-file ;
  51
  52 DEFER: ?make-staging-image
  53
  54 : staging-command-line ( profile -- flags )
  55     [
  56         dup empty? [
  57             "-i=" my-boot-image-name append ,
  58         ] [
  59             dup but-last ?make-staging-image
  60
  61             "-resource-path=" "" resource-path append ,
  62
  63             "-i=" over but-last staging-image-name append ,
  64
  65             "-run=tools.deploy.restage" ,
  66         ] if
  67
  68         "-output-image=" over staging-image-name append ,
  69
  70         "-include=" swap " " join append ,
  71
  72         strip-word-names? [ "-no-stack-traces" , ] when
  73
  74         "-no-user-init" ,
  75     ] { } make ;
  76
  77 : run-factor ( vm flags -- )
  78     swap prefix dup . run-with-output ; inline
  79
  80 : make-staging-image ( profile -- )
  81     vm swap staging-command-line run-factor ;
  82
  83 : ?make-staging-image ( profile -- )
  84     dup staging-image-name exists?
  85     [ drop ] [ make-staging-image ] if ;
  86
  87 : deploy-command-line ( image vocab config -- flags )
  88     [
  89         bootstrap-profile ?make-staging-image
  90
  91         [
  92             "-i=" bootstrap-profile staging-image-name append ,
  93
  94             "-resource-path=" "" resource-path append ,
  95
  96             "-run=tools.deploy.shaker" ,
  97
  98             "-deploy-vocab=" prepend ,
  99
 100             "-output-image=" prepend ,
 101
 102             strip-word-names? [ "-no-stack-traces" , ] when
 103         ] { } make
 104     ] bind ;
 105
 106 : make-deploy-image ( vm image vocab config -- )
 107     make-boot-image
 108     deploy-command-line run-factor ;
 109
 110 HOOK: deploy* os ( vocab -- )