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.files.temp io.pathnames
   8 io.directories io.directories.hierarchy io.backend quotations
   9 io.launcher words.private tools.deploy.config
  10 tools.deploy.config.editor bootstrap.image io.encodings.utf8
  11 destructors accessors ;
  12 IN: tools.deploy.backend
  13
  14 : copy-vm ( executable bundle-name extension -- vm )
  15     [ prepend-path ] dip append vm over copy-file ;
  16
  17 : copy-fonts ( name dir -- )
  18     deploy-ui? get [
  19         append-path "resource:fonts/" swap copy-tree-into
  20     ] [ 2drop ] if ;
  21
  22 : image-name ( vocab bundle-name -- str )
  23     prepend-path ".image" append ;
  24
  25 : copy-lines ( -- )
  26     readln [ print flush copy-lines ] when* ;
  27
  28 : run-with-output ( arguments -- )
  29     <process>
  30         swap >>command
  31         +stdout+ >>stderr
  32         +closed+ >>stdin
  33         +low-priority+ >>priority
  34     utf8 [ copy-lines ] with-process-reader ;
  35
  36 : make-boot-image ( -- )
  37     #! If stage1 image doesn't exist, create one.
  38     my-boot-image-name resource-path exists?
  39     [ my-arch make-image ] unless ;
  40
  41 : bootstrap-profile ( -- profile )
  42     {
  43         { "math"     deploy-math?     }
  44         { "compiler" deploy-compiler? }
  45         { "threads"  deploy-threads?  }
  46         { "ui"       deploy-ui?       }
  47         { "unicode"  deploy-unicode?  }
  48     } [ nip get ] assoc-filter keys
  49     native-io? [ "io" suffix ] when ;
  50
  51 : staging-image-name ( profile -- name )
  52     "staging."
  53     swap strip-word-names? [ "strip" suffix ] when
  54     "-" join ".image" 3append temp-file ;
  55
  56 DEFER: ?make-staging-image
  57
  58 : staging-command-line ( profile -- flags )
  59     [
  60         "-staging" ,
  61
  62         dup empty? [
  63             "-i=" my-boot-image-name append ,
  64         ] [
  65             dup but-last ?make-staging-image
  66
  67             "-resource-path=" "" resource-path append ,
  68
  69             "-i=" over but-last staging-image-name append ,
  70
  71             "-run=tools.deploy.restage" ,
  72         ] if
  73
  74         "-output-image=" over staging-image-name append ,
  75
  76         "-include=" swap " " join append ,
  77
  78         strip-word-names? [ "-no-stack-traces" , ] when
  79
  80         "-no-user-init" ,
  81     ] { } make ;
  82
  83 : run-factor ( vm flags -- )
  84     swap prefix dup . run-with-output ; inline
  85
  86 : make-staging-image ( profile -- )
  87     vm swap staging-command-line run-factor ;
  88
  89 : ?make-staging-image ( profile -- )
  90     dup staging-image-name exists?
  91     [ drop ] [ make-staging-image ] if ;
  92
  93 : make-deploy-config ( vocab -- file )
  94     [ deploy-config unparse-use ]
  95     [ "deploy-config-" prepend temp-file ] bi
  96     [ utf8 set-file-contents ] keep ;
  97
  98 : deploy-command-line ( image vocab config -- flags )
  99     [
 100         bootstrap-profile ?make-staging-image
 101
 102         [
 103             "-i=" bootstrap-profile staging-image-name append ,
 104
 105             "-resource-path=" "" resource-path append ,
 106
 107             "-run=tools.deploy.shaker" ,
 108
 109             [ "-deploy-vocab=" prepend , ]
 110             [ make-deploy-config "-deploy-config=" prepend , ] bi
 111
 112             "-output-image=" prepend ,
 113
 114             strip-word-names? [ "-no-stack-traces" , ] when
 115         ] { } make
 116     ] bind ;
 117
 118 : make-deploy-image ( vm image vocab config -- )
 119     make-boot-image
 120     deploy-command-line run-factor ;
 121
 122 HOOK: deploy* os ( vocab -- )